path: root/stdlib/source/library/lux/debug.lux

(.require
 [library
  [lux (.except private type)
   ["[0]" ffi (.only import)]
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["<>" parser]
    ["[0]" pipe]
    ["[0]" function]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" text (.only)
     ["%" \\format (.only Format)]]
    [format
     [xml (.only XML)]
     ["[0]" json]]
    [collection
     ["[0]" array]
     ["[0]" list (.use "[1]#[0]" monad)]
     ["[0]" dictionary]]]
   [math
    [number
     [ratio (.only Ratio)]
     ["n" nat]
     ["i" int]]]
   ["[0]" meta (.only)
    ["@" target]
    ["[0]" code (.only)
     ["<[1]>" \\parser]]
    [macro
     ["^" pattern]
     ["[0]" template]
     ["[0]" syntax (.only syntax)]]
    ["[0]" type (.only)
     ["<[1]>" \\parser (.only Parser)]]]
   [world
    [time (.only Time)
     [instant (.only Instant)]
     [duration (.only Duration)]
     [date (.only Date)]
     [month (.only Month)]
     [day (.only Day)]]]]])

(with_expansions [<jvm> (these (import java/lang/String
                                 "[1]::[0]")

                               (import (java/lang/Class a)
                                 "[1]::[0]"
                                 (getCanonicalName [] java/lang/String))

                               (import java/lang/Object
                                 "[1]::[0]"
                                 (new [])
                                 (toString [] java/lang/String)
                                 (getClass [] (java/lang/Class java/lang/Object)))

                               (import java/lang/Integer
                                 "[1]::[0]"
                                 (longValue [] long))

                               (import java/lang/Long
                                 "[1]::[0]"
                                 (intValue [] int))

                               (import java/lang/Number
                                 "[1]::[0]"
                                 (intValue [] int)
                                 (longValue [] long)
                                 (doubleValue [] double)))]
  (for @.old (these <jvm>)
       @.jvm (these <jvm>)

       @.js
       (these (import JSON
                "[1]::[0]"
                ("static" stringify [.Any] ffi.String))
              (import Array
                "[1]::[0]"
                ("static" isArray [.Any] ffi.Boolean)))

       @.python
       (these (.type PyType
                (Primitive "python_type"))
              
              (import (type [.Any] PyType))
              (import (str [.Any] ffi.String)))

       @.lua
       (these (import (type [.Any] ffi.String))
              (import (tostring [.Any] ffi.String))

              (import math
                "[1]::[0]"
                ("static" type [.Any] "?" ffi.String)))

       @.ruby
       (these (import Class
                "[1]::[0]")

              (import Object
                "[1]::[0]"
                (class [] Class)
                (to_s [] ffi.String)))

       @.php
       (these (import (gettype [.Any] ffi.String))
              (import (strval [.Any] ffi.String)))

       @.scheme
       (these (import (boolean? [.Any] Bit))
              (import (integer? [.Any] Bit))
              (import (real? [.Any] Bit))
              (import (string? [.Any] Bit))
              (import (vector? [.Any] Bit))
              (import (pair? [.Any] Bit))
              (import (car [.Any] .Any))
              (import (cdr [.Any] .Any))
              (import (format [Text .Any] Text)))
       ))

(def Inspector
  (.type_literal (Format Any)))

(for @.lua (def (tuple_array tuple)
             (-> (array.Array Any) (array.Array Any))
             (array.of_list
              (loop (again [idx 0])
                (let [member ("lua array read" idx tuple)]
                  (if ("lua object nil?" member)
                    {.#End}
                    {.#Item member (again (++ idx))})))))
     (these))

(def (tuple_inspection inspection)
  (-> Inspector Inspector)
  (with_expansions [<adaption> (for @.lua (,, (these ..tuple_array))
                                    (,, (these)))]
    (`` (|>> (as (array.Array Any))
             <adaption>
             (array.list {.#None})
             (list#each inspection)
             (text.interposed " ")
             (text.enclosed ["[" "]"])))))

(def .public (inspection value)
  Inspector
  (with_expansions [<jvm> (let [object (as java/lang/Object value)]
                            (`` (<| (,, (with_template [<class> <processing>]
                                          [(when (ffi.as <class> object)
                                             {.#Some value}
                                             (`` (|> value (,, (template.spliced <processing>))))
                                             
                                             {.#None})]

                                          [java/lang/Boolean [ffi.of_boolean %.bit]]
                                          [java/lang/Long [ffi.of_long %.int]]
                                          [java/lang/Number [java/lang/Number::doubleValue ffi.of_double %.frac]]
                                          [java/lang/String [ffi.of_string %.text]]
                                          ))
                                    (when (ffi.as [java/lang/Object] object)
                                      {.#Some value}
                                      (let [value (as (array.Array java/lang/Object) value)]
                                        (when (array.item 0 value)
                                          (^.multi {.#Some tag}
                                                   [(ffi.as java/lang/Integer tag)
                                                    {.#Some tag}]
                                                   [[(array.item 1 value) (array.item 2 value)]
                                                    [last? {.#Some choice}]])
                                          (let [last? (when last?
                                                        {.#Some _} #1
                                                        {.#None} #0)]
                                            (|> (%.format (%.nat (.nat (ffi.of_long (java/lang/Integer::longValue tag))))
                                                          " " (%.bit last?)
                                                          " " (inspection choice))
                                                (text.enclosed ["{" "}"])))

                                          _
                                          (tuple_inspection inspection value)))
                                      {.#None})
                                    (ffi.of_string (java/lang/Object::toString object)))))]
    (for @.old <jvm>
         @.jvm <jvm>

         @.js
         (when (ffi.type_of value)
           (^.with_template [<type_of> <then>]
             [<type_of>
              (`` (|> value (,, (template.spliced <then>))))])
           (["boolean" [(as .Bit) %.bit]]
            ["number" [(as .Frac) %.frac]]
            ["string" [(as .Text) %.text]]
            ["undefined" [JSON::stringify]])
           
           "object"
           (let [variant_tag ("js object get" "_lux_tag" value)
                 variant_flag ("js object get" "_lux_flag" value)
                 variant_value ("js object get" "_lux_value" value)]
             (cond (not (or ("js object undefined?" variant_tag)
                            ("js object undefined?" variant_flag)
                            ("js object undefined?" variant_value)))
                   (|> (%.format (JSON::stringify variant_tag)
                                 " " (%.bit (not ("js object null?" variant_flag)))
                                 " " (inspection variant_value))
                       (text.enclosed ["{" "}"]))

                   (not (or ("js object undefined?" ("js object get" "_lux_low" value))
                            ("js object undefined?" ("js object get" "_lux_high" value))))
                   (|> value (as .Int) %.int)

                   (Array::isArray value)
                   (tuple_inspection inspection value)
                   
                   ... else
                   (JSON::stringify value)))

           _
           (JSON::stringify value))

         @.python
         (when (..str (..type value))
           (^.with_template [<type_of> <class_of> <then>]
             [(^.or <type_of> <class_of>)
              (`` (|> value (,, (template.spliced <then>))))])
           (["<type 'bool'>" "<class 'bool'>" [(as .Bit) %.bit]]
            ["<type 'int'>" "<class 'int'>" [(as .Int) %.int]]
            ["<type 'float'>" "<class 'float'>" [(as .Frac) %.frac]]
            ["<type 'str'>" "<class 'str'>" [(as .Text) %.text]]
            ["<type 'unicode'>" "<class 'unicode'>" [(as .Text) %.text]])

           (^.or "<type 'list'>" "<class 'list'>")
           (tuple_inspection inspection value)

           (^.or "<type 'tuple'>" "<class 'tuple'>")
           (let [variant (as (array.Array Any) value)]
             (when (array.size variant)
               3 (let [variant_tag ("python array read" 0 variant)
                       variant_flag ("python array read" 1 variant)
                       variant_value ("python array read" 2 variant)]
                   (if (or ("python object none?" variant_tag)
                           ("python object none?" variant_value))
                     (..str value)
                     (|> (%.format (|> variant_tag (as .Nat) %.nat)
                                   " " (|> variant_flag "python object none?" not %.bit)
                                   " " (inspection variant_value))
                         (text.enclosed ["{" "}"]))))
               _ (..str value)))

           _
           (..str value))

         @.lua
         (when (..type value)
           (^.with_template [<type_of> <then>]
             [<type_of>
              (`` (|> value (,, (template.spliced <then>))))])
           (["boolean" [(as .Bit) %.bit]]
            ["string" [(as .Text) %.text]]
            ["nil" [(pipe.new "nil" [])]])

           "number"
           (when (math::type value)
             {.#Some "integer"} (|> value (as .Int) %.int)
             {.#Some "float"} (|> value (as .Frac) %.frac)
             
             _
             (..tostring value))
           
           "table"
           (let [variant_tag ("lua object get" "_lux_tag" value)
                 variant_flag ("lua object get" "_lux_flag" value)
                 variant_value ("lua object get" "_lux_value" value)]
             (if (or ("lua object nil?" variant_tag)
                     ("lua object nil?" variant_value))
               (tuple_inspection inspection value)
               (|> (%.format (|> variant_tag (as .Nat) %.nat)
                             " " (%.bit (not ("lua object nil?" variant_flag)))
                             " " (inspection variant_value))
                   (text.enclosed ["{" "}"]))))

           _
           (..tostring value))

         @.ruby
         (template.let [(class_of <literal>)
                        [(|> <literal>
                             (as ..Object)
                             Object::class)]

                        (to_s <object>)
                        [(|> <object>
                             (as ..Object)
                             Object::to_s)]]
           (let [value_class (class_of value)]
             (`` (cond (,, (with_template [<literal> <type> <format>]
                             [(same? (class_of <literal>) value_class)
                              (|> value (as <type>) <format>)]

                             [#0 Bit %.bit]
                             [#1 Bit %.bit]
                             [+1 Int %.int]
                             [+1.0 Frac %.frac]
                             ["" Text %.text]
                             [("ruby object nil") Any (pipe.new "nil" [])]
                             ))

                       (same? (class_of {.#None}) value_class)
                       (let [variant_tag ("ruby object get" "_lux_tag" value)
                             variant_flag ("ruby object get" "_lux_flag" value)
                             variant_value ("ruby object get" "_lux_value" value)]
                         (if (or ("ruby object nil?" variant_tag)
                                 ("ruby object nil?" variant_value))
                           (tuple_inspection inspection value)
                           (|> (%.format (|> variant_tag (as .Nat) %.nat)
                                         " " (%.bit (not ("ruby object nil?" variant_flag)))
                                         " " (inspection variant_value))
                               (text.enclosed ["{" "}"]))))

                       (same? (class_of [[] []]) value_class)
                       (tuple_inspection inspection value)

                       ... else
                       (to_s value)))))

         @.php
         (when (..gettype value)
           (^.with_template [<type_of> <then>]
             [<type_of>
              (`` (|> value (,, (template.spliced <then>))))])
           (["boolean" [(as .Bit) %.bit]]
            ["integer" [(as .Int) %.int]]
            ["double" [(as .Frac) %.frac]]
            ["string" [(as .Text) %.text]]
            ["NULL" [(pipe.new "null" [])]]
            ["array" [(tuple_inspection inspection)]])

           "object"
           (let [variant_tag ("php object get" "_lux_tag" value)
                 variant_flag ("php object get" "_lux_flag" value)
                 variant_value ("php object get" "_lux_value" value)]
             (if (or ("php object null?" variant_tag)
                     ("php object null?" variant_value))
               (..strval value)
               (|> (%.format (|> variant_tag (as .Nat) %.nat)
                             " " (%.bit (not ("php object null?" variant_flag)))
                             " " (inspection variant_value))
                   (text.enclosed ["{" "}"]))))

           _
           (..strval value))

         @.scheme
         (`` (cond (,, (with_template [<when> <then>]
                         [(<when> value)
                          (`` (|> value (,, (template.spliced <then>))))]

                         [..boolean? [(as .Bit) %.bit]]
                         [..integer? [(as .Int) %.int]]
                         [..real? [(as .Frac) %.frac]]
                         [..string? [(as .Text) %.text]]
                         ["scheme object nil?" [(pipe.new "()" [])]]
                         [..vector? [(tuple_inspection inspection)]]))

                   (..pair? value)
                   (let [variant_tag (..car value)
                         variant_rest (..cdr value)]
                     (if (and (..integer? variant_tag)
                              (i.> +0 (as Int variant_tag))
                              (..pair? variant_rest))
                       (let [variant_flag (..car variant_rest)
                             variant_value (..cdr variant_rest)]
                         (|> (%.format (|> variant_tag (as .Nat) %.nat)
                                       " " (%.bit (not ("scheme object nil?" variant_flag)))
                                       " " (inspection variant_value))
                             (text.enclosed ["{" "}"])))
                       (..format ["~s" value])))

                   ... else
                   (..format ["~s" value])
                   ))
         )))

(exception.def .public (cannot_represent_value type)
  (Exception Type)
  (exception.report
   (list ["Type" (%.type type)])))

(.type Representation
  (-> Any Text))

(def primitive_representation
  (Parser Representation)
  (`` (all <>.either
           (do <>.monad
             [_ (<type>.exactly Any)]
             (in (function.constant "[]")))
           
           (,, (with_template [<type> <formatter>]
                 [(do <>.monad
                    [_ (<type>.sub <type>)]
                    (in (|>> (as <type>) <formatter>)))]

                 [Bit %.bit]
                 [Nat %.nat]
                 [Int %.int]
                 [Rev %.rev]
                 [Frac %.frac]
                 [Text %.text]))
           )))

(def (special_representation representation)
  (-> (Parser Representation) (Parser Representation))
  (`` (all <>.either
           (,, (with_template [<type> <formatter>]
                 [(do <>.monad
                    [_ (<type>.sub <type>)]
                    (in (|>> (as <type>) <formatter>)))]

                 [Ratio %.ratio]
                 [Symbol %.symbol]
                 [Location %.location]
                 [Type %.type]
                 [Code %.code]
                 
                 [Instant %.instant]
                 [Duration %.duration]
                 [Date %.date]
                 [Time %.time]
                 [Month %.month]
                 [Day %.day]
                 
                 [json.JSON %.json]
                 [XML %.xml]))

           (do <>.monad
             [[_ elemT] (<type>.applied (<>.and (<type>.exactly List) <type>.any))
              elemR (<type>.local (list elemT) representation)]
             (in (|>> (as (List Any)) (%.list elemR))))

           (do <>.monad
             [[_ elemT] (<type>.applied (<>.and (<type>.exactly Maybe) <type>.any))
              elemR (<type>.local (list elemT) representation)]
             (in (|>> (as (Maybe Any))
                      (%.maybe elemR)))))))

(def (variant_representation representation)
  (-> (Parser Representation) (Parser Representation))
  (do <>.monad
    [membersR+ (<type>.variant (<>.many representation))]
    (in (function (_ variantV)
          (let [[lefts right? sub_repr] (loop (again [lefts 0
                                                      representations membersR+
                                                      variantV variantV])
                                          (when representations
                                            {.#Item leftR {.#Item rightR extraR+}}
                                            (when (as (Or Any Any) variantV)
                                              {.#Left left}
                                              [lefts #0 (leftR left)]

                                              {.#Right right}
                                              (when extraR+
                                                {.#End}
                                                [lefts #1 (rightR right)]

                                                _
                                                (again (++ lefts) {.#Item rightR extraR+} right)))

                                            _
                                            (undefined)))]
            (%.format "{" (%.nat lefts) " " (%.bit right?) " " sub_repr "}"))))))

(def (tuple_representation representation)
  (-> (Parser Representation) (Parser Representation))
  (do <>.monad
    [membersR+ (<type>.tuple (<>.many representation))]
    (in (function (_ tupleV)
          (let [tuple_body (loop (again [representations membersR+
                                         tupleV tupleV])
                             (when representations
                               {.#End}
                               ""
                               
                               {.#Item lastR {.#End}}
                               (lastR tupleV)
                               
                               {.#Item headR tailR}
                               (let [[leftV rightV] (as [Any Any] tupleV)]
                                 (%.format (headR leftV) " " (again tailR rightV)))))]
            (%.format "[" tuple_body "]"))))))

(def representation_parser
  (Parser Representation)
  (<>.rec
   (function (_ representation)
     (all <>.either
          ..primitive_representation
          (..special_representation representation)
          (..variant_representation representation)
          (..tuple_representation representation)

          (do <>.monad
            [[funcT inputsT+] (<type>.applied (<>.and <type>.any (<>.many <type>.any)))]
            (when (type.applied inputsT+ funcT)
              {.#Some outputT}
              (<type>.local (list outputT) representation)

              {.#None}
              (<>.failure "")))

          (do <>.monad
            [[name anonymous] <type>.named]
            (<type>.local (list anonymous) representation))

          (<>.failure "")
          ))))

(def .public (representation type value)
  (-> Type Any (Try Text))
  (when (<type>.result ..representation_parser type)
    {try.#Success representation}
    {try.#Success (representation value)}

    {try.#Failure _}
    (exception.except ..cannot_represent_value type)))

(def .public private
  (syntax (_ [definition <code>.global])
    (let [[module _] definition]
      (in (list (` (.in_module#
                    (, (code.text module))
                    (, (code.symbol definition)))))))))

(def .public log!
  (-> Text Any)
  (|>> .log#))

(exception.def .public (type_hole [location type])
  (Exception [Location Type])
  (exception.report
   (list ["Location" (%.location location)]
         ["Type" (%.type type)])))

(def .public hole
  (syntax (_ [])
    (do meta.monad
      [location meta.location
       expectedT meta.expected_type]
      (function.constant (exception.except ..type_hole [location expectedT])))))

(.type Target
  [Text (Maybe Code)])

(def target
  (<code>.Parser Target)
  (<>.either (<>.and <code>.local
                     (at <>.monad in {.#None}))
             (<code>.tuple (<>.and <code>.local
                                   (at <>.monad each (|>> {.#Some}) <code>.any)))))

(exception.def .public (unknown_local_binding name)
  (Exception Text)
  (exception.report
   (list ["Name" (%.text name)])))

(def .public here
  (syntax (_ [targets (is (<code>.Parser (List Target))
                          (|> ..target
                              <>.some
                              (<>.else (list))))])
    (do [! meta.monad]
      [location meta.location
       locals meta.locals
       .let [environment (|> locals
                             list.together
                             ... The list is reversed to make sure that, when building the dictionary,
                             ... later bindings overshadow earlier ones if they have the same name.
                             list.reversed
                             (dictionary.of_list text.hash))]
       targets (is (Meta (List Target))
                   (when targets
                     {.#End}
                     (|> environment
                         dictionary.keys
                         (list#each (function (_ local) [local {.#None}]))
                         in)

                     _
                     (monad.each ! (function (_ [name format])
                                     (if (dictionary.key? environment name)
                                       (in [name format])
                                       (function.constant (exception.except ..unknown_local_binding [name]))))
                                 targets)))]
      (in (list (` (..log! (.text_composite#
                            (, (code.text (%.format (%.location location) text.new_line)))
                            (exception.report
                             (.list (,* (|> targets
                                            (list#each (function (_ [name format])
                                                         (let [format (when format
                                                                        {.#None}
                                                                        (` ..inspection)
                                                                        
                                                                        {.#Some format}
                                                                        format)]
                                                           (` [(, (code.text name))
                                                               ((, format) (, (code.local name)))]))))))))))))))))