path: root/new-luxc/source/luxc/lang/host/common-lisp.lux

(.module:
  [lux #- not or and list if function cond when let type-of]
  (lux (control pipe)
       (data [maybe "maybe/" Functor<Maybe>]
             [text]
             text/format
             [number]
             (coll [list "list/" Functor<List> Fold<List>]))
       (type abstract)))

(abstract: #export Single {} Top)
(abstract: #export Poly {} Top)

(abstract: #export (Var kind)
  {}

  Text

  (def: name (All [k] (-> (Var k) Text)) (|>> @representation))

  (def: #export var (-> Text (Var Single)) (|>> @abstraction))

  (def: #export (poly vars)
    (-> (List (Var Single)) (Var Poly))
    (@abstraction
     (format "(" (|> vars (list/map ..name) (text.join-with " ")) ")")))

  (def: #export (poly+ vars rest)
    (-> (List (Var Single)) (Var Single) (Var Poly))
    (@abstraction
     (format "(" (|> vars (list/map ..name) (text.join-with " "))
             " &rest " (..name rest)
             ")")))
  )

(type: #export SVar (Var Single))
(type: #export PVar (Var Poly))
(type: #export *Var (Ex [k] (Var k)))

(abstract: #export Expression
  {}
  
  Text

  (def: #export expression (-> Expression Text) (|>> @representation))

  (def: #export code (-> Text Expression) (|>> @abstraction))

  (type: #export Lambda [PVar Expression])

  (def: #export nil
    Expression
    (@abstraction "()"))

  (def: #export bool
    (-> Bool Expression)
    (|>> (case> true (@abstraction "t")
                false ..nil)))

  (def: #export int
    (-> Int Expression)
    (|>> %i @abstraction))

  (def: #export float
    (-> Frac Expression)
    (|>> (cond> [(f/= number.positive-infinity)]
                [(new> "(/ 1.0 0.0)")]
                
                [(f/= number.negative-infinity)]
                [(new> "(/ -1.0 0.0)")]
                
                [number.not-a-number?]
                [(new> "(/ 0.0 0.0)")]
                
                ## else
                [%f])
         @abstraction))

  (def: #export (double value)
    (-> Frac Expression)
    (@abstraction
     (.cond (f/= number.positive-infinity value)
            "(/ 1.0d0 0.0d0)"
            
            (f/= number.negative-infinity value)
            "(/ -1.0d0 0.0d0)"
            
            (number.not-a-number? value)
            "(/ 0.0d0 0.0d0)"
            
            ## else
            (.let [raw (%f value)]
              (.if (text.contains? "E" raw)
                (text.replace-once "E" "d" raw)
                (format raw "d0"))))))

  (def: #export positive-infinity Expression (..float number.positive-infinity))
  (def: #export negative-infinity Expression (..float number.negative-infinity))
  (def: #export not-a-number Expression (..float number.not-a-number))

  (def: #export string
    (-> Text Expression)
    (|>> %t @abstraction))

  (do-template [<name> <prefix>]
    [(def: #export <name>
       (-> Text Expression)
       (|>> (format <prefix>) @abstraction))]

    [symbol "'"]
    [keyword ":"])

  (def: #export (form elements)
    (-> (List Expression) Expression)
    (@abstraction
     (format "(" (|> elements (list/map expression) (text.join-with " ")) ")")))

  (def: #export @@
    (All [k] (-> (Var k) Expression))
    (|>> ..name @abstraction))

  (def: #export global
    (-> Text Expression)
    (|>> var @@))
  
  (def: #export ($apply func args)
    (-> Expression (List Expression) Expression)
    (form (#.Cons func args)))
  
  (do-template [<name> <function>]
    [(def: #export <name>
       (-> (List Expression) Expression)
       ($apply (..global <function>)))]

    [vector "vector"]
    [list   "list"]
    )

  (def: #export (labels definitions body)
    (-> (List [SVar Lambda]) Expression Expression)
    (..form (.list (..global "labels")
                   (..form (list/map (.function (_ [def-name [def-args def-body]])
                                       (..form (.list (@@ def-name)
                                                      (@@ def-args)
                                                      def-body)))
                                     definitions))
                   body)))

  (def: #export (destructuring-bind [bindings expression] body)
    (-> [PVar Expression] Expression Expression)
    (..form (.list (..global "destructuring-bind")
                   (@@ bindings) expression
                   body)))

  (def: #export ($apply1 func)
    (-> Expression (-> Expression Expression))
    (|>> (.list) (..$apply func)))

  (do-template [<lux-name> <scheme-name>]
    [(def: #export <lux-name> (..$apply1 (..global <scheme-name>)))]

    [length "length"]
    [function "function"]
    [copy-seq "copy-seq"]
    [null "null"]
    [car "car"]
    [cdr "cdr"]
    [error "error"]
    [not "not"]
    [floor/1 "floor"]
    [type-of "type-of"]
    [write-to-string "write-to-string"]
    [read-from-string "read-from-string"]
    [print "print"]
    [reverse "reverse"]
    [sxhash/1 "sxhash"]
    [string-upcase/1 "string-upcase"]
    [string-downcase/1 "string-downcase"]
    [char-int/1 "char-int"]
    [text/1 "text"]
    )

  (def: #export (make-array/init size init)
    (-> Expression Expression Expression)
    (..$apply (..global "make-array")
              (.list (..list (.list size))
                     (..keyword "initial-element")
                     init)))

  (def: #export get-universal-time
    Expression
    (..$apply (..global "get-universal-time") (.list)))

  (def: #export (funcall args func)
    (-> (List Expression) Expression Expression)
    (..$apply (..global "funcall") (list& func args)))

  (def: #export (apply args func)
    (-> Expression Expression Expression)
    (..$apply (..global "apply") (.list func args)))
  
  (def: #export ($apply2 func)
    (-> Expression (-> Expression Expression Expression))
    (.function (_ _0 _1)
      (..$apply func (.list _0 _1))))

  (do-template [<lux-name> <scheme-name>]
    [(def: #export <lux-name> (..$apply2 (..global <scheme-name>)))]

    [append "append"]
    [cons "cons"]
    [svref "svref"]
    [char/2 "char"]
    )

  (def: #export (search/start2 reference space start)
    (-> Expression Expression Expression Expression)
    (..$apply (..global "search")
              (.list reference space
                     (..keyword "start2") start)))

  (def: #export ($apply3 func)
    (-> Expression (-> Expression Expression Expression Expression))
    (.function (_ _0 _1 _2)
      (..$apply func (.list _0 _1 _2))))

  (do-template [<lux-name> <scheme-name>]
    [(def: #export <lux-name> ($apply3 (..global <scheme-name>)))]

    [subseq/3 "subseq"]
    [map/3 "map"]
    [concatenate/3 "concatenate"]
    [format/3 "format"]
    )

  (def: #export concatenate/string
    (-> Expression Expression Expression)
    (concatenate/3 (..symbol "string")))

  (do-template [<lux-name> <scheme-name>]
    [(def: #export <lux-name>
       (-> (List Expression) Expression)
       (|>> (.list& (..global <scheme-name>)) ..form))]

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

  (do-template [<lux-name> <scheme-name>]
    [(def: #export (<lux-name> param subject)
       (-> Expression Expression Expression)
       (..form (.list (..global <scheme-name>) subject param)))]

    [=   "="]
    [eq "eq"]
    [equal "equal"]
    [<   "<"]
    [<=  "<="]
    [>   ">"]
    [>=  ">="]
    [string= "string="]
    [string< "string<"]
    [+   "+"]
    [-   "-"]
    [/   "/"]
    [*   "*"]
    [rem "rem"]
    [floor "floor"]
    [mod "mod"]
    [ash "ash"]
    [logand "logand"]
    [logior "logior"]
    [logxor "logxor"]
    )

  (do-template [<lux-name> <scheme-name>]
    [(def: #export (<lux-name> bindings body)
       (-> (List [SVar Expression]) Expression Expression)
       (..form (.list (..global <scheme-name>)
                      (|> bindings
                          (list/map (.function (_ [fname fvalue])
                                      (..form (.list (@@ fname) fvalue))))
                          ..form)
                      body)))]

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

  (def: #export (if test then else)
    (-> Expression Expression Expression Expression)
    (..form (.list (..global "if") test then else)))

  (def: #export (when test then)
    (-> Expression Expression Expression)
    (..form (.list (..global "when") test then)))

  (def: #export (cond clauses else)
    (-> (List [Expression Expression]) Expression Expression)
    (list/fold (.function (_ [test then] next)
                 (if test then next))
               else
               (list.reverse clauses)))

  (def: #export (lambda input body)
    (-> PVar Expression Expression)
    (..form (.list (..global "lambda")
                   (@@ input)
                   body)))

  (def: #export (defparameter name body)
    (-> SVar Expression Expression)
    (..form (.list (..global "defparameter") (@@ name) body)))

  (def: #export (defun name inputs body)
    (-> SVar (List SVar) Expression Expression)
    (..form (.list (..global "defun") (@@ name) (@@ (..poly inputs)) body)))

  (def: #export progn
    (-> (List Expression) Expression)
    (|>> (#.Cons (..global "progn")) ..form))

  (def: #export (setq! name value)
    (-> SVar Expression Expression)
    (..form (.list (..global "setq") (@@ name) value)))

  (def: #export (setf! access value)
    (-> Expression Expression Expression)
    (..form (.list (..global "setf") access value)))

  (type: #export Handler
    {#condition-type Expression
     #condition SVar
     #body Expression})
  
  (def: #export (handler-case handlers body)
    (-> (List Handler) Expression Expression)
    (..form (.list& (..global "handler-case")
                    body
                    (list/map (.function (_ [type condition handler])
                                (..form (.list type (@@ (..poly (.list condition)))
                                               handler)))
                              handlers))))

  (do-template [<name> <prefix>]
    [(def: #export (<name> conditions expression)
       (-> (List Text) Expression Expression)
       (case conditions
         #.Nil
         expression
         
         (#.Cons single #.Nil)
         (@abstraction
          (format <prefix> single " " (@representation expression)))
         
         _
         (@abstraction
          (format <prefix> (|> conditions (list/map ..symbol)
                               (.list& (..symbol "or")) ..form
                               @representation)
                  " " (@representation expression)))))]

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