path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux

(.require
 [library
  [lux (.except)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["<>" parser]
    ["[0]" maybe]
    ["[0]" try]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]
     ["[0]" dictionary (.only Dictionary)]]]
   [math
    [number
     ["n" nat]]]
   ["[0]" meta (.only)
    ["[0]" code
     ["<[1]>" \\parser (.only Parser)]]
    [macro
     ["^" pattern]]
    [type
     ["[0]" check]]]]]
 ["[0]" /// (.only)
  ["[1][0]" bundle]
  ["/[1]" //
   [//
    ["[1][0]" analysis (.only Analysis Operation Phase Handler Bundle)
     [evaluation (.only Eval)]
     ["[0]A" type]]
    [///
     ["[1]" phase]
     [meta
      [archive (.only Archive)]]]]]])

(def .public (custom [syntax handler])
  (All (_ s)
    (-> [(Parser s)
         (-> Text Phase Archive s (Operation Analysis))]
        Handler))
  (function (_ extension_name analyse archive args)
    (when (<code>.result syntax args)
      {try.#Success inputs}
      (handler extension_name analyse archive inputs)

      {try.#Failure _}
      (////analysis.except ///.invalid_syntax [extension_name %.code args]))))

(def (simple inputsT+ outputT)
  (-> (List Type) Type Handler)
  (let [num_expected (list.size inputsT+)]
    (function (_ extension_name analyse archive args)
      (let [num_actual (list.size args)]
        (if (n.= num_expected num_actual)
          (do [! ////.monad]
            [_ (typeA.inference outputT)
             argsA (monad.each !
                               (function (_ [argT argC])
                                 (<| (typeA.expecting argT)
                                     (analyse archive argC)))
                               (list.zipped_2 inputsT+ args))]
            (in {////analysis.#Extension extension_name argsA}))
          (////analysis.except ///.incorrect_arity [extension_name num_expected num_actual]))))))

(def .public (nullary valueT)
  (-> Type Handler)
  (simple (list) valueT))

(def .public (unary inputT outputT)
  (-> Type Type Handler)
  (simple (list inputT) outputT))

(def .public (binary subjectT paramT outputT)
  (-> Type Type Type Handler)
  (simple (list subjectT paramT) outputT))

(def .public (trinary subjectT param0T param1T outputT)
  (-> Type Type Type Type Handler)
  (simple (list subjectT param0T param1T) outputT))

... TODO: Get rid of this ASAP
(these
 (exception.def .public (char_text_must_be_size_1 text)
   (Exception Text)
   (exception.report
    (list ["Text" (%.text text)])))
 
 (def text_char
   (Parser text.Char)
   (do <>.monad
     [raw <code>.text]
     (when (text.size raw)
       1 (in (|> raw (text.char 0) maybe.trusted))
       _ (<>.failure (exception.error ..char_text_must_be_size_1 [raw])))))

 (def lux::syntax_char_case!
   (..custom
    [(all <>.and
          <code>.any
          (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char))
                                         <code>.any)))
          <code>.any)
     (function (_ extension_name phase archive [input conditionals else])
       (do [! ////.monad]
         [input (<| (typeA.expecting text.Char)
                    (phase archive input))
          expectedT (///.lifted meta.expected_type)
          conditionals (monad.each ! (function (_ [cases branch])
                                       (do !
                                         [branch (<| (typeA.expecting expectedT)
                                                     (phase archive branch))]
                                         (in [cases branch])))
                                   conditionals)
          else (<| (typeA.expecting expectedT)
                   (phase archive else))]
         (in (|> conditionals
                 (list#each (function (_ [cases branch])
                              (////analysis.tuple
                               (list (////analysis.tuple (list#each (|>> ////analysis.nat) cases))
                                     branch))))
                 (list.partial input else)
                 {////analysis.#Extension extension_name}))))])))

... "lux is" represents reference/pointer equality.
(def lux::is
  Handler
  (function (_ extension_name analyse archive args)
    (<| typeA.with_var
        (function (_ [@var :var:]))
        ((binary :var: :var: Bit extension_name)
         analyse archive args))))

... "lux try" provides a simple way to interact with the host platform's
... error_handling facilities.
(def lux::try
  Handler
  (function (_ extension_name analyse archive args)
    (when args
      (list opC)
      (<| typeA.with_var
          (function (_ [@var :var:]))
          (do [! ////.monad]
            [_ (typeA.inference (type_literal (Either Text :var:)))]
            (|> opC
                (analyse archive)
                (typeA.expecting (type_literal (-> .Any :var:)))
                (at ! each (|>> list {////analysis.#Extension extension_name})))))
      
      _
      (////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)]))))

(def lux::in_module
  Handler
  (function (_ extension_name analyse archive argsC+)
    (when argsC+
      (list [_ {.#Text module_name}] exprC)
      (////analysis.with_current_module module_name
        (analyse archive exprC))
      
      _
      (////analysis.except ///.invalid_syntax [extension_name %.code argsC+]))))

(def (lux::type::check eval)
  (-> Eval Handler)
  (function (_ extension_name analyse archive args)
    (when args
      (list typeC valueC)
      (do [! ////.monad]
        [actualT (at ! each (|>> (as Type))
                     (eval archive Type typeC))
         _ (typeA.inference actualT)]
        (<| (typeA.expecting actualT)
            (analyse archive valueC)))

      _
      (////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)]))))

(def (lux::type::as eval)
  (-> Eval Handler)
  (function (_ extension_name analyse archive args)
    (when args
      (list typeC valueC)
      (do [! ////.monad]
        [actualT (at ! each (|>> (as Type))
                     (eval archive Type typeC))
         _ (typeA.inference actualT)
         [valueT valueA] (typeA.inferring
                          (analyse archive valueC))]
        (in valueA))

      _
      (////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)]))))

(def (caster input output)
  (-> Type Type Handler)
  (..custom
   [<code>.any
    (function (_ extension_name phase archive valueC)
      (do [! ////.monad]
        [_ (typeA.inference output)]
        (<| (typeA.expecting input)
            (phase archive valueC))))]))

(exception.def .public (not_a_type symbol)
  (Exception Symbol)
  (exception.report
   (list ["Symbol" (%.symbol symbol)])))

(def lux::macro
  Handler
  (..custom
   [<code>.any
    (function (_ extension_name phase archive valueC)
      (do [! ////.monad]
        [_ (typeA.inference .Macro)
         input_type (loop (again [input_name (symbol .Macro')])
                      (do !
                        [input_type (///.lifted (meta.definition (symbol .Macro')))]
                        (when input_type
                          (^.or {.#Definition [exported? def_type def_value]}
                                {.#Type [exported? def_value labels]})
                          (in (as Type def_value))

                          (^.or {.#Tag _}
                                {.#Slot _})
                          (////.failure (exception.error ..not_a_type [(symbol .Macro')]))

                          {.#Alias real_name}
                          (again real_name))))]
        (<| (typeA.expecting input_type)
            (phase archive valueC))))]))

(def (bundle::lux eval)
  (-> Eval Bundle)
  (|> ///bundle.empty
      (///bundle.install "syntax char case!" lux::syntax_char_case!)
      (///bundle.install "is" lux::is)
      (///bundle.install "try" lux::try)
      (///bundle.install "type check" (lux::type::check eval))
      (///bundle.install "type as" (lux::type::as eval))
      (///bundle.install "macro" ..lux::macro)
      (///bundle.install "type check type" (..caster .Type .Type))
      (///bundle.install "in-module" lux::in_module)))

(def bundle::io
  Bundle
  (<| (///bundle.prefix "io")
      (|> ///bundle.empty
          (///bundle.install "log" (unary Text Any))
          (///bundle.install "error" (unary Text Nothing))
          (///bundle.install "exit" (unary Int Nothing)))))

(def I64*
  (type_literal (I64 Any)))

(def bundle::i64
  Bundle
  (<| (///bundle.prefix "i64")
      (|> ///bundle.empty
          (///bundle.install "and" (binary I64* I64* I64))
          (///bundle.install "or" (binary I64* I64* I64))
          (///bundle.install "xor" (binary I64* I64* I64))
          (///bundle.install "left-shift" (binary Nat I64* I64))
          (///bundle.install "right-shift" (binary Nat I64* I64))
          (///bundle.install "=" (binary I64* I64* Bit))
          (///bundle.install "<" (binary Int Int Bit))
          (///bundle.install "+" (binary I64* I64* I64))
          (///bundle.install "-" (binary I64* I64* I64))
          (///bundle.install "*" (binary Int Int Int))
          (///bundle.install "/" (binary Int Int Int))
          (///bundle.install "%" (binary Int Int Int))
          (///bundle.install "f64" (unary Int Frac))
          (///bundle.install "char" (unary Int Text)))))

(def bundle::f64
  Bundle
  (<| (///bundle.prefix "f64")
      (|> ///bundle.empty
          (///bundle.install "+" (binary Frac Frac Frac))
          (///bundle.install "-" (binary Frac Frac Frac))
          (///bundle.install "*" (binary Frac Frac Frac))
          (///bundle.install "/" (binary Frac Frac Frac))
          (///bundle.install "%" (binary Frac Frac Frac))
          (///bundle.install "=" (binary Frac Frac Bit))
          (///bundle.install "<" (binary Frac Frac Bit))
          (///bundle.install "i64" (unary Frac Int))
          (///bundle.install "encode" (unary Frac Text))
          (///bundle.install "decode" (unary Text (type_literal (Maybe Frac)))))))

(def bundle::text
  Bundle
  (<| (///bundle.prefix "text")
      (|> ///bundle.empty
          (///bundle.install "=" (binary Text Text Bit))
          (///bundle.install "<" (binary Text Text Bit))
          (///bundle.install "concat" (binary Text Text Text))
          (///bundle.install "index" (trinary Nat Text Text (type_literal (Maybe Nat))))
          (///bundle.install "size" (unary Text Nat))
          (///bundle.install "char" (binary Nat Text Nat))
          (///bundle.install "clip" (trinary Nat Nat Text Text))
          )))

(def .public (bundle eval)
  (-> Eval Bundle)
  (<| (///bundle.prefix "lux")
      (|> ///bundle.empty
          (dictionary.composite (bundle::lux eval))
          (dictionary.composite bundle::i64)
          (dictionary.composite bundle::f64)
          (dictionary.composite bundle::text)
          (dictionary.composite bundle::io)
          )))