path: root/stdlib/source/library/lux/meta/compiler/target/common_lisp.lux

(.require
 [library
  [lux (.except Code int if cond or and comment let symbol)
   [control
    ["[0]" pipe]]
   [data
    ["[0]" text
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" monad monoid)]]]
   [math
    [number
     ["f" frac]]]
   [meta
    [macro
     ["[0]" template]]
    [type
     ["[0]" nominal (.except def)]]]]])

(def as_form
  (-> Text Text)
  (text.enclosed ["(" ")"]))

(nominal.def .public (Code brand)
  Text

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

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

  (with_template [<type> <super>]
    [(with_expansions [<brand> (template.symbol [<type> "'"])]
       (`` (nominal.def .public (<brand> brand) Any))
       (`` (type .public (<type> brand)
             (<super> (<brand> brand)))))]

    [Expression Code]
    [Computation Expression]
    [Access Computation]
    [Var Access]

    [Input Code]
    )

  (with_template [<type> <super>]
    [(with_expansions [<brand> (template.symbol [<type> "'"])]
       (`` (nominal.def .public <brand> Any))
       (`` (type .public <type> (<super> <brand>))))]

    [Label Code]
    [Tag Expression]
    [Literal Expression]
    [Var/1 Var]
    [Var/* Input]
    )

  (type .public Lambda
    (Record
     [#input Var/*
      #output (Expression Any)]))

  (def .public nil
    Literal
    (abstraction "()"))

  (with_template [<prefix> <name>]
    [(def .public <name>
       (-> Text Literal)
       (|>> (format <prefix>) abstraction))]
    
    ["'" symbol]
    [":" keyword])

  (def .public bool
    (-> Bit Literal)
    (|>> (pipe.when
           #0 ..nil
           #1 (..symbol "t"))))

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

  (def .public float
    (-> Frac Literal)
    (|>> (pipe.cond [(f.= f.positive_infinity)]
                    [(pipe.new "(/ 1.0 0.0)" [])]
                    
                    [(f.= f.negative_infinity)]
                    [(pipe.new "(/ -1.0 0.0)" [])]
                    
                    [f.not_a_number?]
                    [(pipe.new "(/ 0.0 0.0)" [])]
                    
                    ... else
                    [%.frac])
         abstraction))

  (def .public (double value)
    (-> Frac Literal)
    (abstraction
     (.cond (f.= f.positive_infinity value)
            "(/ 1.0d0 0.0d0)"
            
            (f.= f.negative_infinity value)
            "(/ -1.0d0 0.0d0)"
            
            (f.not_a_number? value)
            "(/ 0.0d0 0.0d0)"
            
            ... else
            (.let [raw (%.frac value)]
              (.if (text.contains? "E" raw)
                (text.replaced_once "E" "d" raw)
                (format raw "d0"))))))

  (def safe
    (-> Text Text)
    (`` (|>> (,, (with_template [<find> <replace>]
                   [(text.replaced <find> <replace>)]

                   ["\" "\\"]
                   [text.tab "\t"]
                   [text.vertical_tab "\v"]
                   [text.null "\0"]
                   [text.back_space "\b"]
                   [text.form_feed "\f"]
                   [text.new_line "\n"]
                   [text.carriage_return "\r"]
                   [text.double_quote (format "\" text.double_quote)]
                   ))
             )))

  (def .public string
    (-> Text Literal)
    (|>> ..safe
         (text.enclosed' text.double_quote)
         abstraction))

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

  (def .public args
    (-> (List Var/1) Var/*)
    (|>> (list#each ..code)
         (text.interposed " ")
         ..as_form
         abstraction))

  (def .public (args& singles rest)
    (-> (List Var/1) Var/1 Var/*)
    (|> (when singles
          {.#End}
          ""
          
          {.#Item _}
          (|> singles
              (list#each ..code)
              (text.interposed " ")
              (text.suffix " ")))
        (format "&rest " (representation rest))
        ..as_form
        abstraction))

  (def form
    (-> (List (Expression Any)) Expression)
    (|>> (list#each ..code)
         (text.interposed " ")
         ..as_form
         abstraction))

  (def .public (call/* func)
    (-> (Expression Any) (-> (List (Expression Any)) (Computation Any)))
    (|>> {.#Item func} ..form))
  
  (with_template [<name> <function>]
    [(def .public <name>
       (-> (List (Expression Any)) (Computation Any))
       (..call/* (..var <function>)))]

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

  (def .public (labels definitions body)
    (-> (List [Var/1 Lambda]) (Expression Any) (Computation Any))
    (..form (list (..var "labels")
                  (..form (list#each (function (_ [def_name [def_args def_body]])
                                       (..form (list def_name (transmutation def_args) def_body)))
                                     definitions))
                  body)))

  (def .public (destructuring_bind [bindings expression] body)
    (-> [Var/* (Expression Any)] (List (Expression Any)) (Computation Any))
    (..form (list.partial (..var "destructuring-bind")
                          (transmutation bindings) expression
                          body)))

  (with_template [<call> <input_var>+ <input_type>+ <function>+]
    [(`` (def .public (<call> [(,, (template.spliced <input_var>+))] function)
           (-> [(,, (template.spliced <input_type>+))] (Expression Any) (Computation Any))
           (..call/* function (list (,, (template.spliced <input_var>+))))))

     (`` (with_template [<lux_name> <host_name>]
           [(def .public (<lux_name> args)
              (-> [(,, (template.spliced <input_type>+))] (Computation Any))
              (<call> args (..var <host_name>)))]
           
           (,, (template.spliced <function>+))))]

    [call/0 [] []
     [[get_universal_time/0 "get-universal-time"]
      [make_hash_table/0 "make-hash-table"]]]
    [call/1 [in0] [(Expression Any)]
     [[length/1 "length"]
      [function/1 "function"]
      [copy_seq/1 "copy-seq"]
      [null/1 "null"]
      [error/1 "error"]
      [not/1 "not"]
      [floor/1 "floor"]
      [type_of/1 "type-of"]
      [write_to_string/1 "write-to-string"]
      [read_from_string/1 "read-from-string"]
      [print/1 "print"]
      [reverse/1 "reverse"]
      [sxhash/1 "sxhash"]
      [string_upcase/1 "string-upcase"]
      [string_downcase/1 "string-downcase"]
      [char_int/1 "char-int"]
      [text/1 "text"]
      [hash_table_size/1 "hash-table-size"]
      [hash_table_rehash_size/1 "hash-table-rehash-size"]
      [code_char/1 "code-char"]
      [char_code/1 "char-code"]
      [string/1 "string"]
      [write_line/1 "write-line"]
      [pprint/1 "pprint"]
      [identity/1 "identity"]]]
    [call/2 [in0 in1] [(Expression Any) (Expression Any)]
     [[apply/2 "apply"]
      [append/2 "append"]
      [cons/2 "cons"]
      [char/2 "char"]
      [nth/2 "nth"]
      [nthcdr/2 "nthcdr"]
      [coerce/2 "coerce"]
      [eq/2 "eq"]
      [equal/2 "equal"]
      [string=/2 "string="]
      [=/2   "="]
      [+/2   "+"]
      [*/2   "*"]]]
    [call/3 [in0 in1 in2] [(Expression Any) (Expression Any) (Expression Any)]
     [[subseq/3 "subseq"]
      [map/3 "map"]
      [concatenate/3 "concatenate"]
      [format/3 "format"]]]
    )

  (with_template [<call> <input_type>+ <function>+]
    [(`` (with_template [<lux_name> <host_name>]
           [(def .public (<lux_name> args)
              (-> [(,, (template.spliced <input_type>+))] (Access Any))
              (transmutation (<call> args (..var <host_name>))))]
           
           (,, (template.spliced <function>+))))]

    [call/1 [(Expression Any)]
     [[car/1 "car"]
      [cdr/1 "cdr"]
      [cadr/1 "cadr"]
      [cddr/1 "cddr"]]]
    [call/2 [(Expression Any) (Expression Any)]
     [[svref/2 "svref"]
      [elt/2 "elt"]
      [gethash/2 "gethash"]]]
    )

  (def .public (make_hash_table/with_size size)
    (-> (Expression Any) (Computation Any))
    (..call/* (..var "make-hash-table")
              (list (..keyword "size")
                    size)))

  (def .public (funcall/+ [func args])
    (-> [(Expression Any) (List (Expression Any))] (Computation Any))
    (..call/* (..var "funcall") (list.partial func args)))

  (def .public (search/3 [reference space start])
    (-> [(Expression Any) (Expression Any) (Expression Any)] (Computation Any))
    (..call/* (..var "search")
              (list reference
                    space
                    (..keyword "start2") start)))

  (def .public (concatenate/2|string [left right])
    (-> [(Expression Any) (Expression Any)] (Computation Any))
    (concatenate/3 [(..symbol "string") left right]))

  (with_template [<lux_name> <host_name>]
    [(def .public (<lux_name> left right)
       (-> (Expression Any) (Expression Any) (Computation Any))
       (..form (list (..var <host_name>) left right)))]

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

  (with_template [<lux_name> <host_name>]
    [(def .public (<lux_name> [param subject])
       (-> [(Expression Any) (Expression Any)] (Computation Any))
       (..form (list (..var <host_name>) subject param)))]

    [</2   "<"]
    [<=/2  "<="]
    [>/2   ">"]
    [>=/2  ">="]
    [string</2 "string<"]
    [-/2   "-"]
    [//2   "/"]
    [rem/2 "rem"]
    [floor/2 "floor"]
    [mod/2 "mod"]
    [ash/2 "ash"]
    [logand/2 "logand"]
    [logior/2 "logior"]
    [logxor/2 "logxor"]
    )

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

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

  (def .public (lambda input body)
    (-> Var/* (Expression Any) Literal)
    (..form (list (..var "lambda") (transmutation input) body)))

  (with_template [<lux_name> <host_name>]
    [(def .public (<lux_name> bindings body)
       (-> (List [Var/1 (Expression Any)]) (List (Expression Any)) (Computation Any))
       (..form (list.partial (..var <host_name>)
                             (|> bindings
                                 (list#each (function (_ [name value])
                                              (..form (list name value))))
                                 ..form)
                             body)))]

    [let  "let"]
    [let* "let*"]
    )

  (def .public (defparameter name body)
    (-> Var/1 (Expression Any) (Expression Any))
    (..form (list (..var "defparameter") name body)))

  (def .public (defun name inputs body)
    (-> Var/1 Var/* (Expression Any) (Expression Any))
    (..form (list (..var "defun") name (transmutation inputs) body)))

  (with_template [<name> <symbol>]
    [(def .public <name>
       (-> (List (Expression Any)) (Computation Any))
       (|>> (list.partial (..var <symbol>)) ..form))]

    [progn "progn"]
    [tagbody "tagbody"]
    [values/* "values"]
    )

  (def .public (setq name value)
    (-> Var/1 (Expression Any) (Expression Any))
    (..form (list (..var "setq") name value)))

  (def .public (setf access value)
    (-> (Access Any) (Expression Any) (Expression Any))
    (..form (list (..var "setf") access value)))

  (type .public Handler
    (Record
     [#condition_type (Expression Any)
      #condition Var/1
      #body (Expression Any)]))
  
  (def .public (handler_case handlers body)
    (-> (List Handler) (Expression Any) (Computation Any))
    (..form (list.partial (..var "handler-case")
                          body
                          (list#each (function (_ [type condition handler])
                                       (..form (list type
                                                     (transmutation (..args (list condition)))
                                                     handler)))
                                     handlers))))

  (with_template [<name> <prefix>]
    [(def .public (<name> conditions expression)
       (-> (List Text) (Expression Any) (Expression Any))
       (when conditions
         {.#End}
         expression
         
         {.#Item single {.#End}}
         (abstraction
          (format <prefix> single " " (representation expression)))
         
         _
         (abstraction
          (format <prefix> (|> conditions (list#each ..symbol)
                               (list.partial (..symbol "or")) ..form
                               representation)
                  " " (representation expression)))))]

    [conditional+ "#+"]
    [conditional- "#-"])

  (def .public label
    (-> Text Label)
    (|>> abstraction))

  (def .public (block name body)
    (-> Label (List (Expression Any)) (Computation Any))
    (..form (list.partial (..var "block") (transmutation name) body)))

  (def .public (return_from target value)
    (-> Label (Expression Any) (Computation Any))
    (..form (list (..var "return-from") (transmutation target) value)))

  (def .public (return value)
    (-> (Expression Any) (Computation Any))
    (..form (list (..var "return") value)))

  (def .public (cond clauses else)
    (-> (List [(Expression Any) (Expression Any)]) (Expression Any) (Computation Any))
    (..form (list.partial (..var "cond")
                          (list#composite (list#each (function (_ [test then])
                                                       (..form (list test then)))
                                                     clauses)
                                          (list (..form (list (..bool true) else)))))))

  (def .public tag
    (-> Text Tag)
    (|>> abstraction))

  (def .public go
    (-> Tag (Expression Any))
    (|>> (list (..var "go"))
         ..form))

  (def .public values_list/1
    (-> (Expression Any) (Expression Any))
    (|>> (list (..var "values-list"))
         ..form))

  (def .public (multiple_value_setq bindings values)
    (-> Var/* (Expression Any) (Expression Any))
    (..form (list (..var "multiple-value-setq")
                  (transmutation bindings)
                  values)))
  )

(def .public (while condition body)
  (-> (Expression Any) (Expression Any) (Computation Any))
  (..form (list (..var "loop") (..var "while") condition
                (..var "do") body)))