path: root/new-luxc/test/test/luxc/lang/translation/common.lux

(.module:
  lux
  (lux [io #+ IO]
       (control [monad #+ do]
                pipe)
       (data text/format
             [bit]
             ["e" error]
             [bool "bool/" Eq<Bool>]
             [text "text/" Eq<Text>]
             [number "nat/" Interval<Nat> "int/" Number<Int> Interval<Int> "frac/" Number<Frac> Interval<Frac> "deg/" Interval<Deg>]
             (coll ["a" array]
                   [list]))
       ["r" math/random]
       [macro]
       (macro [code])
       [host]
       test)
  (luxc [lang]
        (lang [synthesis #+ Synthesis]))
  (test/luxc common))

(def: (bit-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [param r.nat
     subject r.nat]
    (with-expansions [<binary> (do-template [<name> <reference> <param-expr>]
                                 [(test <name>
                                        (|> (run (` (<name> (~ (code.nat subject))
                                                            (~ (code.nat param)))))
                                            (case> (#e.Success valueT)
                                                   (n/= (<reference> param subject) (:! Nat valueT))

                                                   (#e.Error error)
                                                   (exec (log! error)
                                                     false))
                                            (let [param <param-expr>])))]

                                 ["lux bit and"                  bit.and param]
                                 ["lux bit or"                   bit.or param]
                                 ["lux bit xor"                  bit.xor param]
                                 ["lux bit shift-left"           bit.shift-left (n/% +64 param)]
                                 ["lux bit unsigned-shift-right" bit.shift-right (n/% +64 param)]
                                 )]
      ($_ seq
          <binary>
          (test "lux bit shift-right"
                (|> (run (` ("lux bit shift-right"
                             (~ (code.int (nat-to-int subject)))
                             (~ (code.nat param)))))
                    (case> (#e.Success valueT)
                           (i/= (bit.signed-shift-right param (nat-to-int subject))
                                (:! Int valueT))

                           (#e.Error error)
                           (exec (log! error)
                             false))
                    (let [param (n/% +64 param)])))
          ))))

(def: (int-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [param (|> r.int (r.filter (|>> (i/= 0) not)))
     subject r.int
     #let [_ (log! (format "  param = " (%i param) "\n"
                           "subject = " (%i subject) "\n"))]]
    (`` ($_ seq
            (~~ (do-template [<name> <reference>]
                  [(test <name>
                         (|> (run (` (<name>)))
                             (case> (#e.Success valueT)
                                    (i/= <reference> (:! Int valueT))

                                    (#e.Error error)
                                    (exec (log! error)
                                      false))))]

                  ["lux int min" int/bottom]
                  ["lux int max" int/top]
                  ))
            (~~ (do-template [<name> <type> <prepare> <comp> <subject-expr>]
                  [(test <name>
                         (|> (run (` (<name> (~ (code.int subject)))))
                             (case> (#e.Success valueT)
                                    (<comp> (<prepare> subject) (:! <type> valueT))

                                    (#e.Error error)
                                    (exec (log! error)
                                      false))
                             (let [subject <subject-expr>])))]

                  ["lux int to-frac" Frac int-to-frac f/= subject]
                  ["lux int char"    Text (|>> (:! Nat) text.from-code) text/= (|> subject
                                                                                   (:! Nat)
                                                                                   (n/% (bit.shift-left +8 +1))
                                                                                   (:! Int))]
                  ))
            (~~ (do-template [<name> <reference> <outputT> <comp>]
                  [(test <name>
                         (exec (log! <name>)
                           (|> (run (` (<name> (~ (code.int subject)) (~ (code.int param)))))
                               (case> (#e.Success valueT)
                                      (<comp> (<reference> param subject) (:! <outputT> valueT))

                                      (#e.Error error)
                                      (exec (log! error)
                                        false)))))]

                  ["lux int +" i/+ Int  i/=]
                  ["lux int -" i/- Int  i/=]
                  ["lux int *" i/* Int  i/=]
                  ["lux int /" i// Int  i/=]
                  ["lux int %" i/% Int  i/=]
                  ["lux int =" i/= Bool bool/=]
                  ["lux int <" i/< Bool bool/=]
                  ))
            ))))

(def: (frac-spec|0 run)
  (-> Runner Test)
  (do r.Monad<Random>
    [param (|> r.frac (r.filter (|>> (f/= 0.0) not)))
     subject r.frac]
    (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>]
                                 [(test <name>
                                        (|> (run (` (<name> (~ (code.frac subject)) (~ (code.frac param)))))
                                            (case> (#e.Success valueT)
                                                   (<comp> (<reference> param subject) (:! <outputT> valueT))

                                                   _
                                                   false)))]

                                 ["lux frac +" f/+ Frac f/=]
                                 ["lux frac -" f/- Frac f/=]
                                 ["lux frac *" f/* Frac f/=]
                                 ["lux frac /" f// Frac f/=]
                                 ["lux frac %" f/% Frac f/=]
                                 ["lux frac =" f/= Bool bool/=]
                                 ["lux frac <" f/< Bool bool/=]
                                 )]
      ($_ seq
          <binary>
          ))))

(def: (frac-spec|1 run)
  (-> Runner Test)
  (do r.Monad<Random>
    [subject r.frac]
    (`` ($_ seq
            (~~ (do-template [<name> <test>]
                  [(test <name>
                         (|> (run (` (<name>)))
                             (case> (#e.Success valueT)
                                    (<test> (:! Frac valueT))

                                    _
                                    false)))]

                  ["lux frac min" (f/= frac/bottom)]
                  ["lux frac max" (f/= frac/top)]
                  ["lux frac not-a-number" number.not-a-number?]
                  ["lux frac positive-infinity" (f/= number.positive-infinity)]
                  ["lux frac negative-infinity" (f/= number.negative-infinity)]
                  ["lux frac smallest" (f/= ("lux frac smallest"))]
                  ))
            (~~ (do-template [<forward> <backward> <test>]
                  [(test <forward>
                         (|> (run (` (<backward> (<forward> (~ (code.frac subject))))))
                             (case> (#e.Success valueT)
                                    (|> valueT (:! Frac) (f/- subject) frac/abs <test>)

                                    (#e.Error error)
                                    (exec (log! error)
                                      false))))]

                  ["lux frac to-int" "lux int to-frac" (f/< 1.0)]))
            ))))

(def: (frac-spec run)
  (-> Runner Test)
  ($_ seq
      (frac-spec|0 run)
      (frac-spec|1 run)))

(def: lower-alpha
  (r.Random Nat)
  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +26) (n/+ +97)))))

(def: upper-alpha
  (r.Random Nat)
  (|> r.nat (:: r.Functor<Random> map (|>> (n/% +26) (n/+ +65)))))

(def: alpha
  (r.Random Nat)
  (r.either lower-alpha
            upper-alpha))

(def: (text-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [sample-size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
     sample0 (r.text' lower-alpha sample-size)
     sample1 (r.text' upper-alpha sample-size)
     sample2 (|> (r.text' alpha sample-size)
                 (r.filter (|>> (text/= sample1) not)))
     char-idx (|> r.nat (:: @ map (n/% sample-size)))
     #let [sample0S (code.text sample0)
           sample1S (code.text sample1)
           sample2S (code.text sample2)
           concatenatedS (` ("lux text concat" (~ sample0S) (~ sample1S)))
           pre-rep-once (format sample0 sample1)
           post-rep-once (format sample0 sample2)
           pre-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample1))
           post-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample2))]]
    ($_ seq
        (test "Can compare texts for equality."
              (and (|> (run (` ("lux text =" (~ sample0S) (~ sample0S))))
                       (case> (#e.Success valueV)
                              (:! Bool valueV)

                              _
                              false))
                   (|> (run (` ("lux text =" (~ sample0S) (~ sample1S))))
                       (case> (#e.Success valueV)
                              (not (:! Bool valueV))

                              _
                              false))))
        (test "Can compare texts for order."
              (|> (run (` ("lux text <" (~ sample1S) (~ sample0S))))
                  (case> (#e.Success valueV)
                         (:! Bool valueV)

                         _
                         false)))
        (test "Can change case of text."
              (and (|> (run (` ("lux text =" (~ sample0S) ("lux text upper" (~ sample0S)))))
                       (case> (#e.Success valueV)
                              (not (:! Bool valueV))

                              _
                              false))
                   (|> (run (` ("lux text =" (~ sample0S) ("lux text lower" ("lux text upper" (~ sample0S))))))
                       (case> (#e.Success valueV)
                              (:! Bool valueV)

                              _
                              false))))
        (test "Can get length of text."
              (|> (run (` ("lux text size" (~ sample0S))))
                  (case> (#e.Success valueV)
                         (n/= sample-size (:! Nat valueV))

                         _
                         false)))
        (test "Can concatenate text."
              (|> (run (` ("lux text size" (~ concatenatedS))))
                  (case> (#e.Success valueV)
                         (n/= (n/* +2 sample-size) (:! Nat valueV))

                         _
                         false)))
        (test "Can find index of sub-text."
              (and (|> (run (` ("lux text index" (~ concatenatedS) (~ sample0S) +0)))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (Maybe Nat) valueV) (#.Some valueV)])
                              (n/= +0 valueV)

                              _
                              false))
                   (|> (run (` ("lux text index" (~ concatenatedS) (~ sample1S) +0)))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (Maybe Nat) valueV) (#.Some valueV)])
                              (n/= sample-size valueV)

                              _
                              false))))
        (test "Text hashing is consistent."
              (|> (run (` ("lux int ="
                           ("lux text hash" (~ sample0S))
                           ("lux text hash" (~ sample0S)))))
                  (case> (#e.Success valueV)
                         (:! Bool valueV)
                         
                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can replace sub-text once."
              (|> (run (` ("lux text ="
                           (~ (code.text post-rep-once))
                           ("lux text replace-once"
                            (~ (code.text pre-rep-once))
                            (~ sample1S)
                            (~ sample2S)))))
                  (case> (#e.Success valueV)
                         (:! Bool valueV)
                         
                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can replace sub-text all times."
              (|> (run (` ("lux text ="
                           (~ (code.text post-rep-all))
                           ("lux text replace-all"
                            (~ (code.text pre-rep-all))
                            (~ sample1S)
                            (~ sample2S)))))
                  (case> (#e.Success valueV)
                         (:! Bool valueV)
                         
                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (let [test-clip (function (_ from to expected)
                          (|> (run (` ("lux text clip"
                                       (~ concatenatedS)
                                       (~ (code.nat from))
                                       (~ (code.nat to)))))
                              (case> (^multi (#e.Success valueV)
                                             [(:! (Maybe Text) valueV) (#.Some valueV)])
                                     (text/= expected valueV)

                                     _
                                     false)))]
          (test "Can clip text to extract sub-text."
                (and (test-clip +0 sample-size sample0)
                     (test-clip sample-size (n/* +2 sample-size) sample1))))
        (test "Can extract individual characters from text."
              (|> (run (` ("lux text char"
                           (~ sample0S)
                           (~ (code.nat char-idx)))))
                  (case> (^multi (#e.Success valueV)
                                 [(:! (Maybe Nat) valueV) (#.Some valueV)])
                         (text.contains? ("lux nat char" valueV)
                                         sample0)

                         _
                         false)))
        )))

(def: (array-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
     idx (|> r.nat (:: @ map (n/% size)))
     value r.nat
     #let [array0S (` ("lux array new" (~ (code.nat size))))
           array1S (` ("lux array put" (~ array0S) (~ (code.nat idx)) (~ (code.nat value))))]]
    ($_ seq
        (test "Can get size of array."
              (|> (run (` ("lux array size" (~ array0S))))
                  (case> (#e.Success valueV)
                         (n/= size (:! Nat valueV))

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can get element from array (if it exists)."
              (and (|> (run (` ("lux array get" (~ array0S) (~ (code.nat idx)))))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (Maybe Nat) valueV) #.None])
                              true

                              _
                              false))
                   (|> (run (` ("lux array get" (~ array1S) (~ (code.nat idx)))))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (Maybe Nat) valueV) (#.Some valueV)])
                              (n/= value valueV)

                              _
                              false))))
        (test "Can remove element from array."
              (|> (run (` ("lux array get"
                           ("lux array remove" (~ array1S)
                            (~ (code.nat idx)))
                           (~ (code.nat idx)))))
                  (case> (^multi (#e.Success valueV)
                                 [(:! (Maybe Nat) valueV) #.None])
                         true

                         _
                         false)))
        )))

(def: (math-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [subject r.frac
     param r.frac]
    (`` ($_ seq
            (~~ (do-template [<name>]
                  [(test (format "Can apply '" <name> "' procedure.")
                         (|> (run (` (<name> (~ (code.frac subject)))))
                             (case> (#e.Success valueV)
                                    true

                                    (#e.Error error)
                                    (exec (log! error)
                                      false))))]

                  ["lux math cos"]
                  ["lux math sin"]
                  ["lux math tan"]
                  ["lux math acos"]
                  ["lux math asin"]
                  ["lux math atan"]
                  ["lux math exp"]
                  ["lux math log"]
                  ["lux math ceil"]
                  ["lux math floor"]))
            (~~ (do-template [<name>]
                  [(test (format "Can apply '" <name> "' procedure.")
                         (|> (run (` (<name> (~ (code.frac subject)) (~ (code.frac param)))))
                             (case> (#e.Success valueV)
                                    true

                                    (#e.Error error)
                                    (exec (log! error)
                                      false))))]

                  ["lux math pow"]))
            ))))

(def: (io-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [message (r.text' alpha +5)]
    ($_ seq
        (test "Can log messages."
              (|> (run (` ("lux io log" (~ (code.text (format "LOG: " message))))))
                  (case> (#e.Success valueV)
                         true

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can throw runtime errors."
              (and (|> (run (` ("lux try" ("lux function" +1 []
                                           ("lux io error" (~ (code.text message)))))))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (e.Error Text) valueV) (#e.Error error)])
                              (text.contains? message error)

                              _
                              false))
                   (|> (run (` ("lux try" ("lux function" +1 []
                                           (~ (code.text message))))))
                       (case> (^multi (#e.Success valueV)
                                      [(:! (e.Error Text) valueV) (#e.Success valueV)])
                              (text/= message valueV)

                              _
                              false))))
        (test "Can obtain current time in milli-seconds."
              (|> (run (` [("lux io current-time") ("lux io current-time")]))
                  (case> (#e.Success valueV)
                         (let [[pre post] (:! [Nat Nat] valueV)]
                           (n/>= pre post))

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        )))

(def: (atom-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [pre r.nat
     post (|> r.nat (r.filter (|>> (n/= pre) not)))
     #let [preS (code.nat pre)
           postS (code.nat post)
           atomS (` ("lux atom new" (~ preS)))]]
    ($_ seq
        (test "Can read atoms."
              (|> (run (` ("lux atom read" (~ atomS))))
                  (case> (#e.Success valueV)
                         (n/= pre (:! Nat valueV))

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can compare-and-swap atoms."
              (and (|> (run (` ("lux let" +0 (~ preS)
                                ("lux let" +1 ("lux atom new" (0))
                                 [("lux atom compare-and-swap" (1) (0) (~ postS))
                                  ("lux atom read" (1))]))))
                       (case> (#e.Success valueV)
                              (let [[swapped? current-value] (:! [Bool Nat] valueV)]
                                (and swapped?
                                     (n/= post current-value)))

                              (#e.Error error)
                              (exec (log! error)
                                false)))
                   (|> (run (` ("lux let" +0 (~ preS)
                                ("lux let" +1 ("lux atom new" (0))
                                 [("lux atom compare-and-swap" (1) (~ postS) (~ postS))
                                  ("lux atom read" (1))]))))
                       (case> (#e.Success valueV)
                              (let [[swapped? current-value] (:! [Bool Nat] valueV)]
                                (and (not swapped?)
                                     (n/= pre current-value)))

                              (#e.Error error)
                              (exec (log! error)
                                false)))))
        )))

(def: (box-spec run)
  (-> Runner Test)
  (do r.Monad<Random>
    [pre r.nat
     post (|> r.nat (r.filter (|>> (n/= pre) not)))
     #let [preS (code.nat pre)
           postS (code.nat post)
           boxS (` ("lux box new" (~ preS)))]]
    ($_ seq
        (test "Can read boxes."
              (|> (run (` ("lux box read" (~ boxS))))
                  (case> (#e.Success valueV)
                         (n/= pre (:! Nat valueV))

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        (test "Can write boxes."
              (|> (run (` ("lux let" +0 (~ boxS)
                           ("lux let" +1 ("lux box write" (~ postS) (0))
                            ("lux box read" (0))))))
                  (case> (#e.Success valueV)
                         (n/= post (:! Nat valueV))

                         (#e.Error error)
                         (exec (log! error)
                           false))))
        )))

(def: (process-spec run)
  (-> Runner Test)
  ($_ seq
      (test "Can query the concurrency level of the machine."
            (|> (run (` ("lux process concurrency-level")))
                (case> (#e.Success valueV)
                       (n/>= +1 (:! Nat valueV))

                       (#e.Error error)
                       (exec (log! error)
                         false))))
      (do r.Monad<Random>
        [delay (|> r.nat (:: @ map (n/% +10)))
         message (r.text +5)]
        (test "Can schedule I/O operations for future execution."
              (|> (run (` ("lux process schedule"
                           (~ (code.nat delay))
                           ("lux function" +1 []
                            ("lux io log" (~ (code.text (format "SCHEDULE: " message))))))))
                  (case> (#e.Success valueV)
                         true

                         (#e.Error error)
                         (exec (log! error)
                           false)))))
      ))

(def: (all-specs run)
  (-> Runner Test)
  ($_ seq
      (bit-spec run)
      (int-spec run)
      (frac-spec run)
      (text-spec run)
      (array-spec run)
      (math-spec run)
      (io-spec run)
      (atom-spec run)
      (box-spec run)
      (process-spec run)
      ))

(context: "[JVM] Common procedures."
  (<| (times +100)
      (all-specs run-jvm)))

(context: "[JS] Common procedures."
  (<| (times +100)
      (all-specs run-js)))

(context: "[Lua] Common procedures."
  (<| (times +100)
      (all-specs run-lua)))

(context: "[Ruby] Common procedures."
  (<| (times +100)
      (all-specs run-ruby)))

(context: "[Python] Common procedures."
  (<| (times +100)
      (all-specs run-python)))

(context: "[R] Common procedures."
  (<| (times +100)
      (all-specs run-r)))

(context: "[Scheme] Common procedures."
  (<| (times +100)
      (all-specs run-scheme)))

(context: "[Common Lisp] Common procedures."
  (<| (times +100)
      (all-specs run-common-lisp)))

(context: "[PHP] Common procedures."
  (<| (times +100)
      (all-specs run-php)))