path: root/stdlib/source/lux/tool/compiler/phase/extension/directive/lux.lux

(.module:
  [lux #*
   [abstract
    ["." monad (#+ do)]]
   [control
    [io (#+ IO)]
    ["." try]
    ["." exception (#+ exception:)]
    ["p" parser
     ["s" code (#+ Parser)]]]
   [data
    ["." product]
    ["." maybe]
    [text
     ["%" format (#+ format)]]
    [collection
     ["." dictionary]]]
   ["." macro
    ["." code]]
   ["." type (#+ :share :by-example) ("#@." equivalence)
    ["." check]]]
  ["." ///
   ["#." bundle]
   ["#." analysis]
   ["#/" //
    ["#." macro (#+ Expander)]
    ["#." generation]
    [analysis
     ["." module]
     [".A" type]]
    ["#/" // #_
     ["#." analysis]
     ["#." synthesis (#+ Synthesis)]
     ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)]
     [default
      ["#." evaluation]]]]])

(def: #export (custom [syntax handler])
  (All [anchor expression directive s]
    (-> [(Parser s)
         (-> Text
             (Phase anchor expression directive)
             s
             (Operation anchor expression directive Requirements))]
        (Handler anchor expression directive)))
  (function (_ extension-name phase inputs)
    (case (s.run syntax inputs)
      (#try.Success inputs)
      (handler extension-name phase inputs)

      (#try.Failure error)
      (////.throw ///.invalid-syntax [extension-name %.code inputs]))))

## TODO: Inline "evaluate!'" into "evaluate!" ASAP
(def: (evaluate!' generate code//type codeS)
  (All [anchor expression directive]
    (-> (////generation.Phase anchor expression directive)
        Type
        Synthesis
        (Operation anchor expression directive [Type expression Any])))
  (/////directive.lift-generation
   (do ////.monad
     [codeT (generate codeS)
      count ////generation.next
      codeV (////generation.evaluate! (format "evaluate" (%.nat count)) codeT)]
     (wrap [code//type codeT codeV]))))

(def: (evaluate! type codeC)
  (All [anchor expression directive]
    (-> Type Code (Operation anchor expression directive [Type expression Any])))
  (do ////.monad
    [state (///.lift ////.get-state)
     #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
           synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
           generate (get@ [#/////directive.generation #/////directive.phase] state)]
     [_ codeA] (/////directive.lift-analysis
                (/////analysis.with-scope
                  (typeA.with-fresh-env
                    (typeA.with-type type
                      (analyse codeC)))))
     codeS (/////directive.lift-synthesis
            (synthesize codeA))]
    (evaluate!' generate type codeS)))

## TODO: Inline "definition'" into "definition" ASAP
(def: (definition' generate name code//type codeS)
  (All [anchor expression directive]
    (-> (////generation.Phase anchor expression directive)
        Name
        Type
        Synthesis
        (Operation anchor expression directive [Type expression Text Any])))
  (/////directive.lift-generation
   (do ////.monad
     [codeT (generate codeS)
      [target-name value directive] (////generation.define! name codeT)
      _ (////generation.save! false name directive)]
     (wrap [code//type codeT target-name value]))))

(def: (definition name expected codeC)
  (All [anchor expression directive]
    (-> Name (Maybe Type) Code
        (Operation anchor expression directive [Type expression Text Any])))
  (do ////.monad
    [state (///.lift ////.get-state)
     #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
           synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
           generate (get@ [#/////directive.generation #/////directive.phase] state)]
     [_ code//type codeA] (/////directive.lift-analysis
                           (/////analysis.with-scope
                             (typeA.with-fresh-env
                               (case expected
                                 #.None
                                 (do @
                                   [[code//type codeA] (typeA.with-inference (analyse codeC))
                                    code//type (typeA.with-env
                                                 (check.clean code//type))]
                                   (wrap [code//type codeA]))

                                 (#.Some expected)
                                 (do @
                                   [codeA (typeA.with-type expected
                                            (analyse codeC))]
                                   (wrap [expected codeA]))))))
     codeS (/////directive.lift-synthesis
            (synthesize codeA))]
    (definition' generate name code//type codeS)))

(def: (refresh expander host-analysis)
  (All [anchor expression directive]
    (-> Expander /////analysis.Bundle (Operation anchor expression directive Any)))
  (do ////.monad
    [[bundle state] ////.get-state
     #let [eval (/////evaluation.evaluator expander
                                           (get@ [#/////directive.synthesis #/////directive.state] state)
                                           (get@ [#/////directive.generation #/////directive.state] state)
                                           (get@ [#/////directive.generation #/////directive.phase] state))]]
    (////.set-state [bundle
                     (update@ [#/////directive.analysis #/////directive.state]
                              (: (-> /////analysis.State+ /////analysis.State+)
                                 (|>> product.right
                                      [(///analysis.bundle eval host-analysis)]))
                              state)])))

(def: (lux::def expander host-analysis)
  (-> Expander /////analysis.Bundle Handler)
  (function (_ extension-name phase inputsC+)
    (case inputsC+
      (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC [_ (#.Bit exported?)]))
      (do ////.monad
        [current-module (/////directive.lift-analysis
                         (///.lift macro.current-module-name))
         #let [full-name [current-module short-name]]
         [type valueT valueN value] (..definition full-name #.None valueC)
         [_ annotationsT annotations] (evaluate! Code annotationsC)
         _ (/////directive.lift-analysis
            (module.define short-name (#.Right [exported? type (:coerce Code annotations) value])))
         #let [_ (log! (format "Definition " (%.name full-name)))]
         _ (/////directive.lift-generation
            (////generation.learn full-name valueN))
         _ (..refresh expander host-analysis)]
        (wrap /////directive.no-requirements))

      _
      (////.throw ///.invalid-syntax [extension-name %.code inputsC+]))))

(def: (def::type-tagged expander host-analysis)
  (-> Expander /////analysis.Bundle Handler)
  (..custom
   [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text)) s.bit)
    (function (_ extension-name phase [short-name valueC annotationsC tags exported?])
      (do ////.monad
        [current-module (/////directive.lift-analysis
                         (///.lift macro.current-module-name))
         #let [full-name [current-module short-name]]
         [_ annotationsT annotations] (evaluate! Code annotationsC)
         #let [annotations (:coerce Code annotations)]
         [type valueT valueN value] (..definition full-name (#.Some .Type) valueC)
         _ (/////directive.lift-analysis
            (do ////.monad
              [_ (module.define short-name (#.Right [exported? type annotations value]))]
              (module.declare-tags tags exported? (:coerce Type value))))
         #let [_ (log! (format "Definition " (%.name full-name)))]
         _ (/////directive.lift-generation
            (////generation.learn full-name valueN))
         _ (..refresh expander host-analysis)]
        (wrap /////directive.no-requirements)))]))

(def: imports
  (Parser (List Import))
  (|> (s.tuple (p.and s.text s.text))
      p.some
      s.tuple))

(def: def::module
  Handler
  (..custom
   [($_ p.and s.any ..imports)
    (function (_ extension-name phase [annotationsC imports])
      (do ////.monad
        [[_ annotationsT annotationsV] (evaluate! Code annotationsC)
         #let [annotationsV (:coerce Code annotationsV)]
         _ (/////directive.lift-analysis
            (do @
              [_ (monad.map @ (function (_ [module alias])
                                (do @
                                  [_ (module.import module)]
                                  (case alias
                                    "" (wrap [])
                                    _ (module.alias alias module))))
                            imports)]
              (module.set-annotations annotationsV)))]
        (wrap {#/////directive.imports imports
               #/////directive.referrals (list)})))]))

(exception: #export (cannot-alias-an-alias {local Alias} {foreign Alias} {target Name})
  (exception.report
   ["Local alias" (%.name local)]
   ["Foreign alias" (%.name foreign)]
   ["Target definition" (%.name target)]))

(def: (define-alias alias original)
  (-> Text Name (/////analysis.Operation Any))
  (do ////.monad
    [current-module (///.lift macro.current-module-name)
     constant (///.lift (macro.find-def original))]
    (case constant
      (#.Left de-aliased)
      (////.throw ..cannot-alias-an-alias [[current-module alias] original de-aliased])
      
      (#.Right [exported? original-type original-annotations original-value])
      (module.define alias (#.Left original)))))

(def: def::alias
  Handler
  (..custom
   [($_ p.and s.local-identifier s.identifier)
    (function (_ extension-name phase [alias def-name])
      (do ////.monad
        [_ (///.lift
            (////.sub [(get@ [#/////directive.analysis #/////directive.state])
                       (set@ [#/////directive.analysis #/////directive.state])]
                      (define-alias alias def-name)))]
        (wrap /////directive.no-requirements)))]))

(template [<mame> <type> <scope>]
  [(def: <mame>
     (All [anchor expression directive]
       (Handler anchor expression directive))
     (function (handler extension-name phase inputsC+)
       (case inputsC+
         (^ (list [_ (#.Text name)] valueC))
         (do ////.monad
           [[_ handlerT handlerV] (evaluate! (:by-example [anchor expression directive]
                                                          {(Handler anchor expression directive)
                                                           handler}
                                                          <type>)
                                             valueC)
            _ (<| <scope>
                  (///.install name)
                  (:share [anchor expression directive]
                          {(Handler anchor expression directive)
                           handler}
                          {<type>
                           (:assume handlerV)}))]
           (wrap /////directive.no-requirements))

         _
         (////.throw ///.invalid-syntax [extension-name %.code inputsC+]))))]

  [def::analysis   /////analysis.Handler                                /////directive.lift-analysis]
  [def::synthesis  /////synthesis.Handler                               /////directive.lift-synthesis]
  [def::generation (////generation.Handler anchor expression directive) /////directive.lift-generation]
  [def::directive  (/////directive.Handler anchor expression directive) (<|)]
  )

## TODO; Both "prepare-program" and "define-program" exist only
## because the old compiler couldn"t handle a fully-inlined definition
## for "def::program". Inline them ASAP.
(def: (prepare-program analyse synthesize programC)
  (All [anchor expression directive output]
    (-> /////analysis.Phase
        /////synthesis.Phase
        Code
        (Operation anchor expression directive Synthesis)))
  (do ////.monad
    [[_ programA] (/////directive.lift-analysis
                   (/////analysis.with-scope
                     (typeA.with-fresh-env
                       (typeA.with-type (type (-> (List Text) (IO Any)))
                         (analyse programC)))))]
    (/////directive.lift-synthesis
     (synthesize programA))))

(def: (define-program generate program programS)
  (All [anchor expression directive output]
    (-> (////generation.Phase anchor expression directive)
        (-> expression directive)
        Synthesis
        (////generation.Operation anchor expression directive Any)))
  (do ////.monad
    [programG (generate programS)]
    (////generation.save! false ["" ""] (program programG))))

(def: (def::program program)
  (All [anchor expression directive]
    (-> (-> expression directive) (Handler anchor expression directive)))
  (function (handler extension-name phase inputsC+)
    (case inputsC+
      (^ (list programC))
      (do ////.monad
        [state (///.lift ////.get-state)
         #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state)
               synthesize (get@ [#/////directive.synthesis #/////directive.phase] state)
               generate (get@ [#/////directive.generation #/////directive.phase] state)]
         programS (prepare-program analyse synthesize programC)
         _ (/////directive.lift-generation
            (define-program generate program programS))]
        (wrap /////directive.no-requirements))

      _
      (////.throw ///.invalid-syntax [extension-name %.code inputsC+]))))

(def: (bundle::def expander host-analysis program)
  (All [anchor expression directive]
    (-> Expander /////analysis.Bundle (-> expression directive) (Bundle anchor expression directive)))
  (<| (///bundle.prefix "def")
      (|> ///bundle.empty
          (dictionary.put "module" def::module)
          (dictionary.put "alias" def::alias)
          (dictionary.put "type tagged" (def::type-tagged expander host-analysis))
          (dictionary.put "analysis" def::analysis)
          (dictionary.put "synthesis" def::synthesis)
          (dictionary.put "generation" def::generation)
          (dictionary.put "directive" def::directive)
          (dictionary.put "program" (def::program program))
          )))

(def: #export (bundle expander host-analysis program)
  (All [anchor expression directive]
    (-> Expander /////analysis.Bundle (-> expression directive) (Bundle anchor expression directive)))
  (<| (///bundle.prefix "lux")
      (|> ///bundle.empty
          (dictionary.put "def" (lux::def expander host-analysis))
          (dictionary.merge (..bundle::def expander host-analysis program)))))