path: root/stdlib/source/library/lux/target/scheme.lux

(.using
 [library
  [lux (.except Code int or and if cond let symbol)
   ["@" target]
   [abstract
    [equivalence (.only Equivalence)]
    [hash (.only Hash)]]
   [control
    ["[0]" pipe]]
   [data
    ["[0]" text
     ["%" format (.only format)]]
    [collection
     ["[0]" list ("[1]#[0]" functor monoid)]]]
   [macro
    ["[0]" template]]
   [math
    [number
     ["n" nat]
     ["f" frac]]]
   [type
    [primitive (.full)]]]])

... Added the carriage return for better Windows compatibility.
(def: \n+
  Text
  (format text.carriage_return text.new_line))

(def: nested
  (-> Text Text)
  (.let [nested_new_line (format text.new_line text.tab)]
    (text.replaced text.new_line nested_new_line)))

(primitive: .public (Code k)
  Text

  (implementation: .public equivalence
    (All (_ brand) (Equivalence (Code brand)))

    (def: (= reference subject)
      (# text.equivalence = (representation reference) (representation subject))))

  (implementation: .public hash
    (All (_ brand) (Hash (Code brand)))

    (def: equivalence ..equivalence)
    (def: hash (|>> representation (# text.hash hash))))

  (template [<type> <brand> <super>+]
    [(primitive: .public (<brand> brand) Any)
     (`` (type: .public <type> (|> Any <brand> (~~ (template.spliced <super>+)))))]
    
    [Expression Expression' [Code]]
    )

  (template [<type> <brand> <super>+]
    [(primitive: .public <brand> Any)
     (`` (type: .public <type> (|> <brand> (~~ (template.spliced <super>+)))))]

    [Var Var' [Expression' Code]]
    [Computation Computation' [Expression' Code]]
    )

  (type: .public Arguments
    (Record
     [#mandatory (List Var)
      #rest (Maybe Var)]))

  (def: .public manual
    (-> Text Code)
    (|>> abstraction))

  (def: .public code
    (-> (Code Any) Text)
    (|>> representation))

  (def: .public var
    (-> Text Var)
    (|>> abstraction))

  (def: (arguments [mandatory rest])
    (-> Arguments (Code Any))
    (case rest
      {.#Some rest}
      (case mandatory
        {.#End}
        rest

        _
        (|> (format " . " (representation rest))
            (format (|> mandatory
                        (list#each ..code)
                        (text.interposed " ")))
            (text.enclosed ["(" ")"])
            abstraction))
      
      {.#None}
      (|> mandatory
          (list#each ..code)
          (text.interposed " ")
          (text.enclosed ["(" ")"])
          abstraction)))

  (def: .public nil
    Computation
    (abstraction "'()"))

  (def: .public bool
    (-> Bit Computation)
    (|>> (pipe.case
           #0 "#f"
           #1 "#t")
         abstraction))

  (def: .public int
    (-> Int Computation)
    (|>> %.int abstraction))

  (def: .public float
    (-> Frac Computation)
    (|>> (pipe.cond [(f.= f.positive_infinity)]
                    [(pipe.new "+inf.0" [])]
                    
                    [(f.= f.negative_infinity)]
                    [(pipe.new "-inf.0" [])]
                    
                    [f.not_a_number?]
                    [(pipe.new "+nan.0" [])]
                    
                    ... else
                    [%.frac])
         abstraction))

  (def: .public positive_infinity Computation (..float f.positive_infinity))
  (def: .public negative_infinity Computation (..float f.negative_infinity))
  (def: .public not_a_number Computation (..float f.not_a_number))

  (def: safe
    (-> Text Text)
    (`` (|>> (~~ (template [<find> <replace>]
                   [(text.replaced <find> <replace>)]

                   ["\" "\\"]
                   ["|" "\|"]
                   [text.alarm "\a"]
                   [text.back_space "\b"]
                   [text.tab "\t"]
                   [text.new_line "\n"]
                   [text.carriage_return "\r"]
                   [text.double_quote (format "\" text.double_quote)]
                   ))
             )))
  
  (def: .public string
    (-> Text Computation)
    (|>> ..safe %.text abstraction))

  (def: .public symbol
    (-> Text Computation)
    (|>> (format "'") abstraction))

  (def: form
    (-> (List (Code Any)) Code)
    (.let [nested_new_line (format \n+ text.tab)]
      (|>> (pipe.case
             {.#End}
             (abstraction "()")
             
             {.#Item head tail}
             (|> tail
                 (list#each (|>> representation ..nested))
                 {.#Item (representation head)}
                 (text.interposed nested_new_line)
                 (text.enclosed ["(" ")"])
                 abstraction)))))
  
  (def: .public (apply args func)
    (-> (List Expression) Expression Computation)
    (..form {.#Item func args}))
  
  (template [<name> <function>]
    [(def: .public (<name> members)
       (-> (List Expression) Computation)
       (..apply members (..var <function>)))]

    [vector/* "vector"]
    [list/*   "list"]
    )

  (def: .public apply/0
    (-> Expression Computation)
    (..apply (list)))

  (template [<lux_name> <scheme_name>]
    [(def: .public <lux_name>
       (apply/0 (..var <scheme_name>)))]

    [newline/0 "newline"]
    )

  (template [<apply> <arg>+ <type>+ <function>+]
    [(`` (def: .public (<apply> procedure)
           (-> Expression (~~ (template.spliced <type>+)) Computation)
           (function (_ (~~ (template.spliced <arg>+)))
             (..apply (list (~~ (template.spliced <arg>+))) procedure))))

     (`` (template [<definition> <function>]
           [(def: .public <definition> (<apply> (..var <function>)))]

           (~~ (template.spliced <function>+))))]

    [apply/1 [_0] [Expression]
     [[exact/1 "exact"]
      [integer->char/1 "integer->char"]
      [char->integer/1 "char->integer"]
      [number->string/1 "number->string"]
      [string->number/1 "string->number"]
      [floor/1 "floor"]
      [truncate/1 "truncate"]
      [string/1 "string"]
      [string?/1 "string?"]
      [length/1 "length"]
      [values/1 "values"]
      [null?/1 "null?"]
      [car/1 "car"]
      [cdr/1 "cdr"]
      [raise/1 "raise"]
      [error_object_message/1 "error-object-message"]
      [make_vector/1 "make-vector"]
      [vector_length/1 "vector-length"]
      [not/1 "not"]
      [string_hash/1 "string-hash"]
      [reverse/1 "reverse"]
      [display/1 "display"]
      [exit/1 "exit"]
      [string_length/1 "string-length"]
      [load_relative/1 "load-relative"]]]

    [apply/2 [_0 _1] [Expression Expression]
     [[append/2 "append"]
      [cons/2 "cons"]
      [make_vector/2 "make-vector"]
      ... [vector_ref/2 "vector-ref"]
      [list_tail/2 "list-tail"]
      [map/2 "map"]
      [string_ref/2 "string-ref"]
      [string_append/2 "string-append"]
      [make_string/2 "make-string"]]]

    [apply/3 [_0 _1 _2] [Expression Expression Expression]
     [[substring/3 "substring"]
      [vector_set!/3 "vector-set!"]
      [string_contains/3 "string-contains"]]]

    [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression]
     [[vector_copy!/5 "vector-copy!"]]]
    )

  ... TODO: define "vector_ref/2" like a normal apply/2 function.
  ... "vector_ref/2" as an 'invoke' is problematic, since it only works
  ... in Kawa.
  ... However, the way Kawa defines "vector-ref" causes trouble,
  ... because it does a runtime type-check which throws an error when
  ... it checks against custom values/objects/classes made for
  ... JVM<->Scheme interop.
  ... There are 2 ways to deal with this:
  ... 0. To fork Kawa, and get rid of the type-check so the normal
  ... "vector-ref" can be used instead.
  ... 1. To carry on, and then, when it's time to compile the compiler
  ... itself into Scheme, switch from 'invoke' to normal 'vector-ref'.
  ... Either way, the 'invoke' needs to go away.
  (def: .public (vector_ref/2 vector index)
    (-> Expression Expression Computation)
    (..form (list (..var "invoke") vector (..symbol "getRaw") index)))

  (template [<lux_name> <scheme_name>]
    [(def: .public (<lux_name> param subject)
       (-> Expression Expression Computation)
       (..apply/2 (..var <scheme_name>) subject param))]

    [=/2   "="]
    [eq?/2 "eq?"]
    [eqv?/2 "eqv?"]
    [</2   "<"]
    [<=/2  "<="]
    [>/2   ">"]
    [>=/2  ">="]
    [string=?/2 "string=?"]
    [string<?/2 "string<?"]
    [+/2   "+"]
    [-/2   "-"]
    [//2   "/"]
    [*/2   "*"]
    [expt/2 "expt"]
    [remainder/2 "remainder"]
    [quotient/2 "quotient"]
    [mod/2 "mod"]
    [arithmetic_shift/2 "arithmetic-shift"]
    [bitwise_and/2 "bitwise-and"]
    [bitwise_ior/2 "bitwise-ior"]
    [bitwise_xor/2 "bitwise-xor"]
    )

  (template [<lux_name> <scheme_name>]
    [(def: .public <lux_name>
       (-> (List Expression) Computation)
       (|>> (partial_list (..var <scheme_name>)) ..form))]

    [or "or"]
    [and "and"]
    )

  (template [<lux_name> <scheme_name> <var> <pre>]
    [(def: .public (<lux_name> bindings body)
       (-> (List [<var> Expression]) Expression Computation)
       (..form (list (..var <scheme_name>)
                     (|> bindings
                         (list#each (function (_ [binding/name binding/value])
                                      (..form (list (|> binding/name <pre>)
                                                    binding/value))))
                         ..form)
                     body)))]

    [let           "let"           Var       (<|)]
    [let*          "let*"          Var       (<|)]
    [letrec        "letrec"        Var       (<|)]
    [let_values    "let-values"    Arguments ..arguments]
    [let*_values   "let*-values"   Arguments ..arguments]
    [letrec_values "letrec-values" Arguments ..arguments]
    )

  (def: .public (if test then else)
    (-> Expression Expression Expression Computation)
    (..form (list (..var "if") test then else)))

  (def: .public (when test then)
    (-> Expression Expression Computation)
    (..form (list (..var "when") test then)))

  (def: .public (lambda arguments body)
    (-> Arguments Expression Computation)
    (..form (list (..var "lambda")
                  (..arguments arguments)
                  body)))

  (def: .public (define_function name arguments body)
    (-> Var Arguments Expression Computation)
    (..form (list (..var "define")
                  (|> arguments
                      (revised #mandatory (|>> {.#Item name}))
                      ..arguments)
                  body)))

  (def: .public (define_constant name value)
    (-> Var Expression Computation)
    (..form (list (..var "define") name value)))

  (def: .public begin
    (-> (List Expression) Computation)
    (|>> {.#Item (..var "begin")} ..form))

  (def: .public (set! name value)
    (-> Var Expression Computation)
    (..form (list (..var "set!") name value)))

  (def: .public (with_exception_handler handler body)
    (-> Expression Expression Computation)
    (..form (list (..var "with-exception-handler") handler body)))

  (def: .public (call_with_current_continuation body)
    (-> Expression Computation)
    (..form (list (..var "call-with-current-continuation") body)))

  (def: .public (guard variable clauses else body)
    (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation)
    (..form (list (..var "guard")
                  (..form (|> (case else
                                {.#None}
                                (list)
                                
                                {.#Some else}
                                (list (..form (list (..var "else") else))))
                              (list#composite (list#each (function (_ [when then])
                                                           (..form (list when then)))
                                                         clauses))
                              (partial_list variable)))
                  body)))
  )