(module morse-code mzscheme
  (require (lib "etc.ss")
           (lib "contract.ss")
           (lib "lex.ss" "parser-tools"))
  
  ;; Simple application of lex.ss of the parser tools to do
  ;; morse code.
  
  (provide/contract [morse-lexer
                     ((char? . -> . any)
                      . -> .
                      (input-port? . -> . any))]

                    [translate-morse-in-string
                     (string? . -> . string?)])

  ;; morse-lexer: (char -> X) -> (input-port -> (union X char 'eof))
  ;;
  ;; Creates a lexer that consumes an input port and tries to 
  ;; translate a single morse-code character.  If it can't, it
  ;; calls the escape procedure 'esc' with the offending character.
  ;; At end of port, returns 'eof.
  (define (morse-lexer esc)
    (lexer
     (".-"    "A")
     ("-..."  "B")
     ("-.-."  "C")
     ("-.."   "D")
     ("."     "E")
     ("..-."  "F")
     ("--."   "G")
     ("...."  "H")
     (".."    "I")
     (".---"  "J")
     ("-.-"   "K")
     (".-.."  "L")
     ("--"    "M")
     ("-."    "N")
     ("---"   "O")
     (".--."  "P")
     ("--.-"  "Q")
     (".-."   "R")
     ("..."   "S")
     ("-"     "T")
     ("..-"   "U")
     ("...-"  "V")
     (".--"   "W")
     ("-..-"  "X")
     ("-.--"  "Y")
     ("--.."  "Z")
     
     (".----" "1")
     ("..---" "2")
     ("...--" "3")
     ("....-" "4")
     ("....." "5")
     ("-...." "6")
     ("--..." "7")
     ("---.." "8")
     ("----." "9")
     ("-----" "0")
     (any-char (esc lexeme))))
  
  ;; translate-morse-in-string: string -> string
  ;; 
  ;; Given a-str, returns a new string where anything
  ;; that looks like morse code (dots and dashes '.' '-')
  ;; are translated; everything else is preserved.
  (define (translate-morse-in-string a-str)
    (let ([lexer (morse-lexer identity)]
          [ip (open-input-string a-str)]
          [op (open-output-string)])
      (let loop ([next-ch (lexer ip)])
        (cond
          [(eq? next-ch 'eof)
           (get-output-string op)]
          [else
           (display next-ch op)
           (loop (lexer ip))])))))