path: root/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux

(.module:
  [library
   [lux (#- Module)
    [abstract
     [monad (#+ do)]]
    [control
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]
     ["." function]]
    [data
     [binary (#+ Binary)]
     ["." product]
     ["." name]
     ["." text ("#\." equivalence)
      ["%" format (#+ format)]]
     [collection
      ["." row (#+ Row)]
      ["." list ("#\." functor)]]]
    [math
     [number
      ["n" nat]]]]]
  [//
   [synthesis (#+ Synthesis)]
   [phase
    ["." extension]]
   [///
    ["." phase]
    [meta
     ["." archive (#+ Archive)
      ["." descriptor (#+ Module)]
      ["." artifact]]]]])

(type: .public Context
  [archive.ID artifact.ID])

(type: .public (Buffer directive)
  (Row [artifact.ID (Maybe Text) directive]))

(exception: .public (cannot_interpret {error Text})
  (exception.report
   ["Error" error]))

(template [<name>]
  [(exception: .public (<name> {artifact_id artifact.ID})
     (exception.report
      ["Artifact ID" (%.nat artifact_id)]))]

  [cannot_overwrite_output]
  [no_buffer_for_saving_code]
  )

(interface: .public (Host expression directive)
  (: (-> Context expression (Try Any))
     evaluate!)
  (: (-> directive (Try Any))
     execute!)
  (: (-> Context (Maybe Text) expression (Try [Text Any directive]))
     define!)

  (: (-> Context Binary directive)
     ingest)
  (: (-> Context (Maybe Text) directive (Try Any))
     re_learn)
  (: (-> Context (Maybe Text) directive (Try Any))
     re_load))

(type: .public (State anchor expression directive)
  {#module Module
   #anchor (Maybe anchor)
   #host (Host expression directive)
   #buffer (Maybe (Buffer directive))
   #registry artifact.Registry
   #counter Nat
   #context (Maybe artifact.ID)
   #log (Row Text)})

(template [<special> <general>]
  [(type: .public (<special> anchor expression directive)
     (<general> (State anchor expression directive) Synthesis expression))]

  [State+    extension.State]
  [Operation extension.Operation]
  [Phase     extension.Phase]
  [Handler   extension.Handler]
  [Bundle    extension.Bundle]
  [Extender  extension.Extender]
  )

(def: .public (state host module)
  (All [anchor expression directive]
    (-> (Host expression directive)
        Module
        (..State anchor expression directive)))
  {#module module
   #anchor #.None
   #host host
   #buffer #.None
   #registry artifact.empty
   #counter 0
   #context #.None
   #log row.empty})

(def: .public empty_buffer Buffer row.empty)

(template [<tag>
           <with_declaration> <with_type> <with_value>
           <set> <get> <get_type> <exception>]
  [(exception: .public <exception>)

   (def: .public <with_declaration>
     (All [anchor expression directive output] <with_type>)
     (function (_ body)
       (function (_ [bundle state])
         (case (body [bundle (set@ <tag> (#.Some <with_value>) state)])
           (#try.Success [[bundle' state'] output])
           (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')]
                          output])

           (#try.Failure error)
           (#try.Failure error)))))

   (def: .public <get>
     (All [anchor expression directive]
       (Operation anchor expression directive <get_type>))
     (function (_ (^@ stateE [bundle state]))
       (case (get@ <tag> state)
         (#.Some output)
         (#try.Success [stateE output])

         #.None
         (exception.except <exception> []))))

   (def: .public (<set> value)
     (All [anchor expression directive]
       (-> <get_type> (Operation anchor expression directive Any)))
     (function (_ [bundle state])
       (#try.Success [[bundle (set@ <tag> (#.Some value) state)]
                      []])))]

  [#anchor
   (with_anchor anchor)
   (-> anchor (Operation anchor expression directive output)
       (Operation anchor expression directive output))
   anchor
   set_anchor anchor anchor no_anchor]

  [#buffer
   with_buffer
   (-> (Operation anchor expression directive output)
       (Operation anchor expression directive output))
   ..empty_buffer
   set_buffer buffer (Buffer directive) no_active_buffer]
  )

(def: .public get_registry
  (All [anchor expression directive]
    (Operation anchor expression directive artifact.Registry))
  (function (_ (^@ stateE [bundle state]))
    (#try.Success [stateE (get@ #registry state)])))

(def: .public (set_registry value)
  (All [anchor expression directive]
    (-> artifact.Registry (Operation anchor expression directive Any)))
  (function (_ [bundle state])
    (#try.Success [[bundle (set@ #registry value state)]
                   []])))

(def: .public next
  (All [anchor expression directive]
    (Operation anchor expression directive Nat))
  (do phase.monad
    [count (extension.read (get@ #counter))
     _ (extension.update (update@ #counter inc))]
    (in count)))

(def: .public (gensym prefix)
  (All [anchor expression directive]
    (-> Text (Operation anchor expression directive Text)))
  (\ phase.monad map (|>> %.nat (format prefix)) ..next))

(def: .public (enter_module module)
  (All [anchor expression directive]
    (-> Module (Operation anchor expression directive Any)))
  (extension.update (set@ #module module)))

(def: .public module
  (All [anchor expression directive]
    (Operation anchor expression directive Module))
  (extension.read (get@ #module)))

(def: .public (evaluate! label code)
  (All [anchor expression directive]
    (-> Context expression (Operation anchor expression directive Any)))
  (function (_ (^@ state+ [bundle state]))
    (case (\ (get@ #host state) evaluate! label code)
      (#try.Success output)
      (#try.Success [state+ output])

      (#try.Failure error)
      (exception.except ..cannot_interpret error))))

(def: .public (execute! code)
  (All [anchor expression directive]
    (-> directive (Operation anchor expression directive Any)))
  (function (_ (^@ state+ [bundle state]))
    (case (\ (get@ #host state) execute! code)
      (#try.Success output)
      (#try.Success [state+ output])

      (#try.Failure error)
      (exception.except ..cannot_interpret error))))

(def: .public (define! context custom code)
  (All [anchor expression directive]
    (-> Context (Maybe Text) expression (Operation anchor expression directive [Text Any directive])))
  (function (_ (^@ stateE [bundle state]))
    (case (\ (get@ #host state) define! context custom code)
      (#try.Success output)
      (#try.Success [stateE output])

      (#try.Failure error)
      (exception.except ..cannot_interpret error))))

(def: .public (save! artifact_id custom code)
  (All [anchor expression directive]
    (-> artifact.ID (Maybe Text) directive (Operation anchor expression directive Any)))
  (do {! phase.monad}
    [?buffer (extension.read (get@ #buffer))]
    (case ?buffer
      (#.Some buffer)
      ## TODO: Optimize by no longer checking for overwrites...
      (if (row.any? (|>> product.left (n.= artifact_id)) buffer)
        (phase.except ..cannot_overwrite_output [artifact_id])
        (extension.update (set@ #buffer (#.Some (row.add [artifact_id custom code] buffer)))))
      
      #.None
      (phase.except ..no_buffer_for_saving_code [artifact_id]))))

(template [<name> <artifact>]
  [(def: .public (<name> name)
     (All [anchor expression directive]
       (-> Text (Operation anchor expression directive artifact.ID)))
     (function (_ (^@ stateE [bundle state]))
       (let [[id registry'] (<artifact> name (get@ #registry state))]
         (#try.Success [[bundle (set@ #registry registry' state)]
                        id]))))]

  [learn artifact.definition]
  [learn_custom artifact.custom]
  [learn_analyser artifact.analyser]
  [learn_synthesizer artifact.synthesizer]
  [learn_generator artifact.generator]
  [learn_directive artifact.directive]
  )

(exception: .public (unknown_definition {name Name}
                                        {known_definitions (List Text)})
  (exception.report
   ["Definition" (name.short name)]
   ["Module" (name.module name)]
   ["Known Definitions" (exception.listing function.identity known_definitions)]))

(def: .public (remember archive name)
  (All [anchor expression directive]
    (-> Archive Name (Operation anchor expression directive Context)))
  (function (_ (^@ stateE [bundle state]))
    (let [[_module _name] name]
      (do try.monad
        [module_id (archive.id _module archive)
         registry (if (text\= (get@ #module state) _module)
                    (#try.Success (get@ #registry state))
                    (do try.monad
                      [[descriptor document] (archive.find _module archive)]
                      (#try.Success (get@ #descriptor.registry descriptor))))]
        (case (artifact.remember _name registry)
          #.None
          (exception.except ..unknown_definition [name (artifact.definitions registry)])
          
          (#.Some id)
          (#try.Success [stateE [module_id id]]))))))

(exception: .public no_context)

(def: .public (module_id module archive)
  (All [anchor expression directive]
    (-> Module Archive (Operation anchor expression directive archive.ID)))
  (function (_ (^@ stateE [bundle state]))
    (do try.monad
      [module_id (archive.id module archive)]
      (in [stateE module_id]))))

(def: .public (context archive)
  (All [anchor expression directive]
    (-> Archive (Operation anchor expression directive Context)))
  (function (_ (^@ stateE [bundle state]))
    (case (get@ #context state)
      #.None
      (exception.except ..no_context [])
      
      (#.Some id)
      (do try.monad
        [module_id (archive.id (get@ #module state) archive)]
        (in [stateE [module_id id]])))))

(def: .public (with_context id body)
  (All [anchor expression directive a]
    (-> artifact.ID
        (Operation anchor expression directive a)
        (Operation anchor expression directive a)))
  (function (_ [bundle state])
    (do try.monad
      [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])]
      (in [[bundle' (set@ #context (get@ #context state) state')]
           output]))))

(def: .public (with_new_context archive body)
  (All [anchor expression directive a]
    (-> Archive (Operation anchor expression directive a)
        (Operation anchor expression directive [Context a])))
  (function (_ (^@ stateE [bundle state]))
    (let [[id registry'] (artifact.resource (get@ #registry state))]
      (do try.monad
        [[[bundle' state'] output] (body [bundle (|> state
                                                     (set@ #registry registry')
                                                     (set@ #context (#.Some id)))])
         module_id (archive.id (get@ #module state) archive)]
        (in [[bundle' (set@ #context (get@ #context state) state')]
             [[module_id id]
              output]])))))

(def: .public (log! message)
  (All [anchor expression directive a]
    (-> Text (Operation anchor expression directive Any)))
  (function (_ [bundle state])
    (#try.Success [[bundle
                    (update@ #log (row.add message) state)]
                   []])))