path: root/stdlib/source/lux/lang/synthesis.lux

(.module:
  [lux #- Scope]
  (lux (control [state]
                ["ex" exception #+ Exception exception:]
                [monad #+ do])
       (data [product]
             [error #+ Error]
             [number]
             (coll (dictionary ["dict" unordered #+ Dict])))
       [function])
  [//reference #+ Register Variable Reference]
  [//analysis #+ Environment Special Analysis])

(type: #export Arity Nat)

(type: #export Resolver (Dict Variable Variable))

(type: #export State
  {#scope-arity Arity
   #resolver Resolver
   #direct? Bool
   #locals Nat})

(def: #export fresh-resolver
  Resolver
  (dict.new //reference.Hash<Variable>))

(def: #export init
  State
  {#scope-arity +0
   #resolver fresh-resolver
   #direct? false
   #locals +0})

(type: (Operation' s o)
  (state.State' Error s o))

(type: #export (Compiler s i o)
  (-> i (Operation' ..State o)))

(type: #export Primitive
  (#Bool Bool)
  (#I64 I64)
  (#F64 Frac)
  (#Text Text))

(type: #export (Structure a)
  (#Variant (//analysis.Variant a))
  (#Tuple (//analysis.Tuple a)))

(type: #export Side
  (Either Nat Nat))

(type: #export Member
  (Either Nat Nat))

(type: #export Access
  (#Side Side)
  (#Member Member))

(type: #export (Path' s)
  #Pop
  (#Test Primitive)
  (#Access Access)
  (#Bind Register)
  (#Alt (Path' s) (Path' s))
  (#Seq (Path' s) (Path' s))
  (#Then s))

(type: #export (Abstraction' s)
  {#environment Environment
   #arity Arity
   #body s})

(type: #export (Branch s)
  (#Case s (Path' s))
  (#Let s Register s)
  (#If s s s)
  (#Exec s))

(type: #export (Scope s)
  {#start Register
   #inits (List s)
   #iteration s})

(type: #export (Loop s)
  (#Scope (Scope s))
  (#Recur (List s)))

(type: #export (Function s)
  (#Abstraction (Abstraction' s))
  (#Apply s (List s)))

(type: #export (Control s)
  (#Branch (Branch s))
  (#Loop (Loop s))
  (#Function (Function s)))

(type: #export #rec Synthesis
  (#Primitive Primitive)
  (#Structure (Structure Synthesis))
  (#Reference Reference)
  (#Control (Control Synthesis))
  (#Special (Special Synthesis)))

(type: #export Path
  (Path' Synthesis))

(def: #export path/pop
  Path
  #Pop)

(do-template [<name> <tag>]
  [(template: #export (<name> content)
     (#..Test (<tag> content)))]

  [path/bool #..Bool]
  [path/i64  #..I64]
  [path/f64  #..F64]
  [path/text #..Text]
  )

(do-template [<name> <tag>]
  [(template: #export (<name> content)
     (<tag> content))]

  [path/alt  #..Alt]
  [path/seq  #..Seq]
  [path/then #..Then]
  )

(type: #export Abstraction
  (Abstraction' Synthesis))

(type: #export (Operation a)
  (Operation' ..State a))

(def: #export unit Text "")

(type: #export Synthesizer
  (Compiler ..State Analysis Synthesis))

(def: #export (throw exception parameters)
  (All [e] (-> (Exception e) e Operation'))
  (state.lift error.Monad<Error>
              (ex.throw exception parameters)))

(def: #export (run synthesizer analysis)
  (-> Synthesizer Analysis (Error Synthesis))
  (:: error.Monad<Error> map product.right
      (synthesizer analysis ..init)))

(def: (localized' transform)
  (-> (-> State State)
      (All [a] (-> (Operation a) (Operation a))))
  (function (_ operation)
    (function (_ state)
      (case (operation (transform state))
        (#error.Error error)
        (#error.Error error)

        (#error.Success [state' output])
        (#error.Success [state output])))))

(def: (localized transform)
  (-> (-> State State)
      (-> Synthesizer Synthesizer))
  (function (_ synthesize)
    (function (_ analysis)
      (localized' transform (synthesize analysis)))))

(do-template [<operation> <synthesizer> <value>]
  [(def: #export <operation>
     (All [a] (-> (Operation a) (Operation a)))
     (localized' (set@ #direct? <value>)))

   (def: #export <synthesizer>
     (-> Synthesizer Synthesizer)
     (localized (set@ #direct? <value>)))]

  [indirectly' indirectly false]
  [directly'   directly   true]
  )

(do-template [<operation> <synthesizer> <type> <tag>]
  [(def: #export (<operation> value)
     (-> <type> (All [a] (-> (Operation a) (Operation a))))
     (localized' (set@ <tag> value)))

   (def: #export (<synthesizer> value)
     (-> <type> (-> Synthesizer Synthesizer))
     (localized (set@ <tag> value)))]

  [with-scope-arity' with-scope-arity Arity    #scope-arity]
  [with-resolver'    with-resolver    Resolver #resolver]
  [with-locals'      with-locals      Nat      #locals]
  )

(def: #export (with-state value)
  (-> ..State (-> Synthesizer Synthesizer))
  (localized (function.constant value)))

(def: #export (with-abstraction-state arity resolver)
  (-> Arity Resolver (-> Synthesizer Synthesizer))
  (with-state {#scope-arity arity
               #resolver resolver
               #direct? true
               #locals arity}))

(do-template [<name> <tag> <type>]
  [(def: #export <name>
     (Operation <type>)
     (function (_ state)
       (#error.Success [state (get@ <tag> state)])))]

  [scope-arity #scope-arity Arity]
  [resolver    #resolver    Resolver]
  [direct?     #direct?     Bool]
  [locals      #locals      Nat]
  )

(def: #export Operation@Monad (state.Monad<State'> error.Monad<Error>))

(def: #export with-new-local'
  (All [a] (-> (Operation a) (Operation a)))
  (<<| (do Operation@Monad
         [locals ..locals])
       (..with-locals' (inc locals))))

(do-template [<name> <tag>]
  [(template: #export (<name> content)
     (<| #..Reference
         <tag>
         content))]

  [variable/local   //reference.local]
  [variable/foreign //reference.foreign]
  )

(do-template [<name> <family> <tag>]
  [(template: #export (<name> content)
     (<| #..Control
         <family>
         <tag>
         content))]

  [branch/case          #..Branch   #..Case]
  [branch/let           #..Branch   #..Let]
  [branch/if            #..Branch   #..If]
  [branch/exec          #..Branch   #..Exec]

  [loop/scope           #..Loop     #..Scope]
  [loop/recur           #..Loop     #..Recur]

  [function/abstraction #..Function #..Abstraction]
  [function/apply       #..Function #..Apply]
  )