path: root/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux

(.module:
  [lux #*
   [control
    ["." monad (#+ do)]
    ["ex" exception (#+ exception:)]
    [thread (#+ Box)]]
   [concurrency
    [atom (#+ Atom)]]
   [data
    ["." text
     format]
    [collection
     ["." list ("list/." Functor<List>)]
     ["." array]
     ["dict" dictionary (#+ Dictionary)]]]
   [type
    ["." check]]
   [io (#+ IO)]]
  ["." ////
   ["." analysis (#+ Analysis Handler Bundle)
    [".A" type]
    [".A" case]
    [".A" function]]]
  ["." ///
   ["." bundle]])

## [Utils]
(def: (simple inputsT+ outputT)
  (-> (List Type) Type Handler)
  (let [num-expected (list.size inputsT+)]
    (function (_ extension-name analyse args)
      (let [num-actual (list.size args)]
        (if (n/= num-expected num-actual)
          (do ////.Monad<Operation>
            [_ (typeA.infer outputT)
             argsA (monad.map @
                              (function (_ [argT argC])
                                (typeA.with-type argT
                                  (analyse argC)))
                              (list.zip2 inputsT+ args))]
            (wrap (#analysis.Extension extension-name argsA)))
          (////.throw bundle.incorrect-arity [extension-name num-expected num-actual]))))))

(def: #export (nullary valueT)
  (-> Type Handler)
  (simple (list) valueT))

(def: #export (unary inputT outputT)
  (-> Type Type Handler)
  (simple (list inputT) outputT))

(def: #export (binary subjectT paramT outputT)
  (-> Type Type Type Handler)
  (simple (list subjectT paramT) outputT))

(def: #export (trinary subjectT param0T param1T outputT)
  (-> Type Type Type Type Handler)
  (simple (list subjectT param0T param1T) outputT))

## [Analysers]
## "lux is" represents reference/pointer equality.
(def: lux::is
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((binary varT varT Bit extension-name)
       analyse 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 args)
    (case args
      (^ (list opC))
      (do ////.Monad<Operation>
        [[var-id varT] (typeA.with-env check.var)
         _ (typeA.infer (type (Either Text varT)))
         opA (typeA.with-type (type (IO varT))
               (analyse opC))]
        (wrap (#analysis.Extension extension-name (list opA))))
      
      _
      (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)]))))

(def: lux::in-module
  Handler
  (function (_ extension-name analyse argsC+)
    (case argsC+
      (^ (list [_ (#.Text module-name)] exprC))
      (analysis.with-current-module module-name
        (analyse exprC))
      
      _
      (////.throw bundle.invalid-syntax [extension-name]))))

## (do-template [<name> <type>]
##   [(def: <name>
##      Handler
##      (function (_ extension-name analyse args)
##        (case args
##          (^ (list typeC valueC))
##          (do ////.Monad<Operation>
##            [actualT (eval Type typeC)
##             _ (typeA.infer (:coerce Type actualT))]
##            (typeA.with-type <type>
##              (analyse valueC)))

##          _
##          (////.throw bundle.incorrect-arity [extension-name 2 (list.size args)]))))]

##   [lux::check  (:coerce Type actualT)]
##   [lux::coerce Any]
##   )

(def: lux::check::type
  Handler
  (function (_ extension-name analyse args)
    (case args
      (^ (list valueC))
      (do ////.Monad<Operation>
        [_ (typeA.infer Type)
         valueA (typeA.with-type Type
                  (analyse valueC))]
        (wrap valueA))
      
      _
      (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)]))))

(def: bundle::lux
  Bundle
  (|> bundle.empty
      (bundle.install "is" lux::is)
      (bundle.install "try" lux::try)
      ## (bundle.install "check" lux::check)
      ## (bundle.install "coerce" lux::coerce)
      (bundle.install "check type" lux::check::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))
          (bundle.install "current-time" (nullary Int)))))

(def: bundle::bit
  Bundle
  (<| (bundle.prefix "bit")
      (|> bundle.empty
          (bundle.install "and" (binary Nat Nat Nat))
          (bundle.install "or" (binary Nat Nat Nat))
          (bundle.install "xor" (binary Nat Nat Nat))
          (bundle.install "left-shift" (binary Nat Nat Nat))
          (bundle.install "logical-right-shift" (binary Nat Nat Nat))
          (bundle.install "arithmetic-right-shift" (binary Int Nat Int))
          )))

(def: bundle::int
  Bundle
  (<| (bundle.prefix "int")
      (|> bundle.empty
          (bundle.install "+" (binary Int Int Int))
          (bundle.install "-" (binary Int Int Int))
          (bundle.install "*" (binary Int Int Int))
          (bundle.install "/" (binary Int Int Int))
          (bundle.install "%" (binary Int Int Int))
          (bundle.install "=" (binary Int Int Bit))
          (bundle.install "<" (binary Int Int Bit))
          (bundle.install "to-frac" (unary Int Frac))
          (bundle.install "char" (unary Int Text)))))

(def: bundle::frac
  Bundle
  (<| (bundle.prefix "frac")
      (|> 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 "smallest" (nullary Frac))
          (bundle.install "min" (nullary Frac))
          (bundle.install "max" (nullary Frac))
          (bundle.install "to-rev" (unary Frac Rev))
          (bundle.install "to-int" (unary Frac Int))
          (bundle.install "encode" (unary Frac Text))
          (bundle.install "decode" (unary Text (type (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 Text Text Nat (type (Maybe Nat))))
          (bundle.install "size" (unary Text Nat))
          (bundle.install "char" (binary Text Nat (type (Maybe Nat))))
          (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text))))
          )))

(def: array::get
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((binary (type (Array varT)) Nat (type (Maybe varT)) extension-name)
       analyse args))))

(def: array::put
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension-name)
       analyse args))))

(def: array::remove
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((binary (type (Array varT)) Nat (type (Array varT)) extension-name)
       analyse args))))

(def: bundle::array
  Bundle
  (<| (bundle.prefix "array")
      (|> bundle.empty
          (bundle.install "new" (unary Nat Array))
          (bundle.install "get" array::get)
          (bundle.install "put" array::put)
          (bundle.install "remove" array::remove)
          (bundle.install "size" (unary (type (Ex [a] (Array a))) Nat))
          )))

(def: atom::new
  Handler
  (function (_ extension-name analyse args)
    (case args
      (^ (list initC))
      (do ////.Monad<Operation>
        [[var-id varT] (typeA.with-env check.var)
         _ (typeA.infer (type (Atom varT)))
         initA (typeA.with-type varT
                 (analyse initC))]
        (wrap (#analysis.Extension extension-name (list initA))))
      
      _
      (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)]))))

(def: atom::read
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((unary (type (Atom varT)) varT extension-name)
       analyse args))))

(def: atom::compare-and-swap
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[var-id varT] (typeA.with-env check.var)]
      ((trinary (type (Atom varT)) varT varT Bit extension-name)
       analyse args))))

(def: bundle::atom
  Bundle
  (<| (bundle.prefix "atom")
      (|> bundle.empty
          (bundle.install "new" atom::new)
          (bundle.install "read" atom::read)
          (bundle.install "compare-and-swap" atom::compare-and-swap)
          )))

(def: box::new
  Handler
  (function (_ extension-name analyse args)
    (case args
      (^ (list initC))
      (do ////.Monad<Operation>
        [[var-id varT] (typeA.with-env check.var)
         _ (typeA.infer (type (All [!] (Box ! varT))))
         initA (typeA.with-type varT
                 (analyse initC))]
        (wrap (#analysis.Extension extension-name (list initA))))
      
      _
      (////.throw bundle.incorrect-arity [extension-name 1 (list.size args)]))))

(def: box::read
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[thread-id threadT] (typeA.with-env check.var)
       [var-id varT] (typeA.with-env check.var)]
      ((unary (type (Box threadT varT)) varT extension-name)
       analyse args))))

(def: box::write
  Handler
  (function (_ extension-name analyse args)
    (do ////.Monad<Operation>
      [[thread-id threadT] (typeA.with-env check.var)
       [var-id varT] (typeA.with-env check.var)]
      ((binary varT (type (Box threadT varT)) Any extension-name)
       analyse args))))

(def: bundle::box
  Bundle
  (<| (bundle.prefix "box")
      (|> bundle.empty
          (bundle.install "new" box::new)
          (bundle.install "read" box::read)
          (bundle.install "write" box::write)
          )))

(def: bundle::process
  Bundle
  (<| (bundle.prefix "process")
      (|> bundle.empty
          (bundle.install "parallelism" (nullary Nat))
          (bundle.install "schedule" (binary Nat (type (IO Any)) Any))
          )))

(def: #export bundle
  Bundle
  (<| (bundle.prefix "lux")
      (|> bundle.empty
          (dict.merge bundle::lux)
          (dict.merge bundle::bit)
          (dict.merge bundle::int)
          (dict.merge bundle::frac)
          (dict.merge bundle::text)
          (dict.merge bundle::array)
          (dict.merge bundle::atom)
          (dict.merge bundle::box)
          (dict.merge bundle::process)
          (dict.merge bundle::io))
      ))