extra/command-loop/command-loop.factor

   1 ! Copyright (C) 2021 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii assocs combinators continuations debugger
   5 formatting grouping io kernel math sequences sorting splitting ;
   6
   7 IN: command-loop
   8
   9 TUPLE: command name quot help abbrevs ;
  10
  11 C: <command> command
  12
  13 TUPLE: command-loop intro prompt commands abbrevs ;
  14
  15 GENERIC: add-command ( command command-loop -- )
  16 GENERIC: find-command ( name command-loop -- command )
  17 GENERIC: handle-command ( args command-loop -- )
  18 GENERIC: missing-command ( args name command-loop -- )
  19 GENERIC: run-command-loop ( command-loop -- )
  20
  21 <PRIVATE
  22
  23 : do-help ( args command-loop -- )
  24     over empty? [
  25         nl
  26         "Commands available:" print
  27         "===================" print
  28         nip commands>> [ name>> ] map natural-sort
  29         [ 6 <groups> ] [ longest length 4 + ] bi
  30         '[ [ _ CHAR: \s pad-tail write ] each nl ] each nl
  31     ] [
  32         dupd find-command [
  33             nip help>> print
  34         ] [
  35             "ERROR: Command '" "' not found" surround print
  36         ] if*
  37     ] if ;
  38
  39 : <help-command> ( command-loop -- command )
  40     "help" swap '[ _ do-help ]
  41     "List available commands with 'help' or detailed help with 'help cmd'"
  42     { "?" } <command> ;
  43
  44 : do-abbrevs ( args command-loop -- )
  45     nl
  46     "Commands abbreviated:" print
  47     "=====================" print
  48     nip abbrevs>> sort-keys [
  49         "%-7s %s\n" printf
  50     ] assoc-each nl ;
  51
  52 : <abbrevs-command> ( command-loop -- command )
  53     "abbrevs" swap '[ _ do-abbrevs ]
  54     "List abbreviated commands" f <command> ;
  55
  56 PRIVATE>
  57
  58 : new-command-loop ( intro prompt class -- command-loop )
  59     new
  60         swap >>prompt
  61         swap >>intro
  62         V{ } clone >>commands
  63         V{ } clone >>abbrevs {
  64         [ <help-command> ]
  65         [ add-command ]
  66         [ <abbrevs-command> ]
  67         [ add-command ]
  68         [ ]
  69     } cleave ;
  70
  71 : <command-loop> ( intro prompt -- command-loop )
  72     command-loop new-command-loop ;
  73
  74 M: command-loop add-command ( command command-loop -- )
  75     {
  76         [ commands>> push ]
  77         [ [ [ name>> ] keep ] dip [ abbrevs>> ] bi@ '[ _ set-at ] with each ]
  78     } 2cleave ;
  79
  80 M: command-loop find-command ( name command-loop -- command )
  81     [ abbrevs>> ?at drop ]
  82     [ commands>> [ name>> = ] with find nip ] bi ;
  83
  84 M: command-loop handle-command
  85     swap " " split1 swap >lower
  86     [ pick find-command ] keep swap [
  87         nip quot>> call( args -- ) drop
  88     ] [
  89         rot missing-command
  90     ] if* flush ;
  91
  92 M: command-loop missing-command ( args name command-loop -- )
  93     drop "ERROR: Unknown command '" "'" surround print drop ;
  94
  95 M: command-loop run-command-loop
  96     dup intro>> [ print ] when* [
  97         dup prompt>> [ write bl flush ] when* readln [
  98             [
  99                 [ over handle-command ]
 100                 [ "ERROR: " write print-error drop ] recover
 101             ] unless-empty t
 102         ] [ f ] if*
 103     ] loop drop ;
 104
 105 : command-loop-main ( -- )
 106     "This is a test!" "TEST>" <command-loop> run-command-loop ;
 107
 108 MAIN: command-loop-main