path: root/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux

... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.

(.require
 [library
  [lux (.except Scope #Function #Apply #locals i64)
   [abstract
    [monad (.only do)]
    [equivalence (.only Equivalence)]
    [hash (.only Hash)]]
   [control
    ["[0]" maybe]]
   [data
    ["[0]" sum]
    ["[0]" product]
    ["[0]" bit (.use "[1]#[0]" equivalence)]
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format (.only Format format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]
     ["[0]" dictionary (.only Dictionary)]]]
   [math
    [number
     ["n" nat]
     ["i" int]
     ["f" frac]
     ["[0]" i64]]]
   [meta
    [macro
     ["^" pattern]]]]]
 ["[0]" /
  ["[1][0]" simple (.only Simple)]
  ["[1][0]" access (.only Access)
   ["[2][0]" side (.only Side)]
   ["[2][0]" member (.only Member)]]
  [//
   ["[0]" analysis (.only Environment)
    ["[1]/[0]" complex (.only Complex)]]
   ["[0]" phase (.only)
    ["[0]" extension (.only Extension)]]
   [///
    [arity (.only Arity)]
    ["[0]" reference (.only Reference)
     ["[0]" variable (.only Register Variable)]]]]])

(type .public Resolver
  (Dictionary Variable Variable))

(type .public State
  (Record
   [#locals Nat
    ... https://en.wikipedia.org/wiki/Currying
    #currying? Bit]))

(def .public fresh_resolver
  Resolver
  (dictionary.empty variable.hash))

(def .public init
  State
  [#locals 0
   #currying? false])

(type .public (Road value next)
  (Record
   [#when value
    #then next]))

(type .public (Fork value next)
  [(Road value next)
   (List (Road value next))])

(type .public (Path' s)
  (Variant
   {#Pop}
   {#Bind Register}
   {#Access Access}
   {#Bit_Fork Bit (Path' s) (Maybe (Path' s))}
   {#I64_Fork (Fork I64 (Path' s))}
   {#F64_Fork (Fork Frac (Path' s))}
   {#Text_Fork (Fork Text (Path' s))}
   {#Seq (Path' s) (Path' s)}
   {#Alt (Path' s) (Path' s)}
   {#Then s}))

(type .public (Abstraction' s)
  (Record
   [#environment (Environment s)
    #arity Arity
    #body s]))

(type .public (Apply' s)
  (Record
   [#function s
    #arguments (List s)]))

(type .public (Branch s)
  (Variant
   {#Exec s s}
   {#Let s Register s}
   {#If s s s}
   {#Get (List Member) s}
   {#When s (Path' s)}))

(type .public (Scope s)
  (Record
   [#start Register
    #inits (List s)
    #iteration s]))

(type .public (Loop s)
  (Variant
   {#Scope (Scope s)}
   {#Again (List s)}))

(type .public (Function s)
  (Variant
   {#Abstraction (Abstraction' s)}
   {#Apply (Apply' s)}))

(type .public (Control s)
  (Variant
   {#Branch (Branch s)}
   {#Loop (Loop s)}
   {#Function (Function s)}))

(with_expansions [@ ($ (Term' $))]
  (type .public (Term' $)
    (Variant
     {#Simple Simple}
     {#Structure (Complex @)}
     {#Reference Reference}
     {#Control (Control @)}
     {#Extension (Extension @)})))

(type .public Term
  (Ann Location
       (Term' (Ann Location))))

(type .public Operation
  (phase.Operation State))

(type .public Phase
  (phase.Phase State analysis.Term Term))

(with_template [<special> <general>]
  [(type .public <special>
     (<general> ..State analysis.Term Term))]

  [Handler   extension.Handler]
  [Bundle    extension.Bundle]
  [Extender  extension.Extender]
  )

(type .public Path
  (Path' Term))

(def .public path/pop
  Path
  {#Pop})

(with_template [<name> <kind>]
  [(def .public <name>
     (template (<name> content)
       [(.<| {..#Access}
             {<kind>}
             content)]))]

  [path/side   /access.#Side]
  [path/member /access.#Member]
  )

(with_template [<name> <access> <lefts> <right?>]
  [(def .public <name>
     (template (<name> lefts right?)
       [(.<| {..#Access}
             {<access>}
             [<lefts> lefts
              <right?> right?])]))]

  [side /access.#Side /side.#lefts /side.#right?]
  [member /access.#Member /member.#lefts /member.#right?]
  )

(with_template [<access> <side> <name>]
  [(def .public <name>
     (template (<name> lefts)
       [(<access> lefts <side>)]))]

  [..side #0 side/left]
  [..side #1 side/right]

  [..member #0 member/left]
  [..member #1 member/right]
  )

(with_template [<name> <tag>]
  [(def .public <name>
     (template (<name> content)
       [{<tag> content}]))]

  [path/bind ..#Bind]
  [path/then ..#Then]
  )

(with_template [<name> <tag>]
  [(def .public <name>
     (template (<name> left right)
       [{<tag> left right}]))]

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

(type .public Abstraction
  (Abstraction' Term))

(type .public Apply
  (Apply' Term))

(def .public unit
  Text
  "")

(with_template [<with> <query> <tag> <type>]
  [(def .public (<with> value)
     (-> <type>
         (All (_ of)
           (-> (Operation of)
               (Operation of))))
     (phase.temporary (has <tag> value)))

   (def .public <query>
     (Operation <type>)
     (phase.read (the <tag>)))]

  [with_locals    locals    #locals    Nat]
  [with_currying? currying? #currying? Bit]
  )

(def .public with_new_local
  (All (_ of)
    (-> (Operation of)
        (Operation of)))
  (<<| (do phase.monad
         [locals ..locals])
       (..with_locals (++ locals))))

(with_template [<name> <tag>]
  [(def .public <name>
     (template (<name> <@> content)
       [[<@> {..#Simple {<tag> content}}]]))]

  [bit  /simple.#Bit]
  [i64  /simple.#I64]
  [f64  /simple.#F64]
  [text /simple.#Text]
  )

(with_template [<name> <tag>]
  [(def .public <name>
     (template (<name> <@> content)
       [(.<| [<@>]
             {..#Structure}
             {<tag>}
             content)]))]

  [variant analysis/complex.#Variant]
  [tuple   analysis/complex.#Tuple]
  )

(with_template [<name> <tag>]
  [(def .public <name>
     (template (<name> <@> content)
       [(.<| [<@>]
             {..#Reference}
             <tag>
             content)]))]

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

(with_template [<name> <family> <tag>]
  [(def .public <name>
     (template (<name> <@> content)
       [(.<| [<@>]
             {..#Control}
             {<family>}
             {<tag>}
             content)]))]

  [branch/when          ..#Branch   ..#When]
  [branch/exec          ..#Branch   ..#Exec]
  [branch/let           ..#Branch   ..#Let]
  [branch/if            ..#Branch   ..#If]
  [branch/get           ..#Branch   ..#Get]

  [loop/again           ..#Loop     ..#Again]
  [loop/scope           ..#Loop     ..#Scope]

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

(def .public (%path' %then value)
  (All (_ of)
    (-> (Format of)
        (Format (Path' of))))
  (when value
    {#Pop}
    "_"

    {#Bit_Fork test then else}
    (format "(?"
            " " (%.bit test) " " (%path' %then then)
            (when else
              {.#Some else}
              (format " " (%.bit (not test)) " " (%path' %then else))

              {.#None}
              "")
            ")")
    
    (^.with_template [<tag> <format>]
      [{<tag> item}
       (|> {.#Item item}
           (list#each (function (_ [test then])
                        (format (<format> test) " " (%path' %then then))))
           (text.interposed " ")
           (text.enclosed ["(? " ")"]))])
    ([#I64_Fork (|>> .int %.int)]
     [#F64_Fork %.frac]
     [#Text_Fork %.text])
    
    {#Access it}
    (/access.format it)
    
    {#Bind register}
    (format "(@ " (%.nat register) ")")
    
    {#Alt left right}
    (format "(| " (%path' %then left) " " (%path' %then right) ")")
    
    {#Seq left right}
    (format "(& " (%path' %then left) " " (%path' %then right) ")")
    
    {#Then then}
    (|> (%then then)
        (text.enclosed ["(! " ")"]))))

(def .public (%synthesis [_ value])
  (Format Term)
  (when value
    {#Simple it}
    (/simple.format it)

    {#Structure structure}
    (when structure
      {analysis/complex.#Variant [lefts right? content]}
      (|> (%synthesis content)
          (format (%.nat lefts) " " (%.bit right?) " ")
          (text.enclosed ["{" "}"]))
      
      {analysis/complex.#Tuple members}
      (|> members
          (list#each %synthesis)
          (text.interposed " ")
          (text.enclosed ["[" "]"])))

    {#Reference reference}
    (reference.format reference)

    {#Control control}
    (when control
      {#Function function}
      (when function
        {#Abstraction [environment arity body]}
        (let [environment' (|> environment
                               (list#each %synthesis)
                               (text.interposed " ")
                               (text.enclosed ["[" "]"]))]
          (|> (format environment' " " (%.nat arity) " " (%synthesis body))
              (text.enclosed ["{#function " "}"])))
        
        {#Apply func args}
        (|> args
            (list#each %synthesis)
            (text.interposed " ")
            (format (%synthesis func) " ")
            (text.enclosed ["(" ")"])))

      {#Branch branch}
      (when branch
        {#Exec this that}
        (|> (format (%synthesis this) " " (%synthesis that))
            (text.enclosed ["{#exec " "}"]))
        
        {#Let input register body}
        (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body))
            (text.enclosed ["{#let " "}"]))
        
        {#If test then else}
        (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else))
            (text.enclosed ["{#if " "}"]))

        {#Get members record}
        (|> (format (%.list (%path' %synthesis)
                            (list#each (|>> {/access.#Member} {#Access}) members))
                    " " (%synthesis record))
            (text.enclosed ["{#get " "}"]))
        
        {#When input path}
        (|> (format (%synthesis input) " " (%path' %synthesis path))
            (text.enclosed ["{#when " "}"])))
      
      {#Loop loop}
      (when loop
        {#Scope scope}
        (|> (format (%.nat (the #start scope))
                    " " (|> (the #inits scope)
                            (list#each %synthesis)
                            (text.interposed " ")
                            (text.enclosed ["[" "]"]))
                    " " (%synthesis (the #iteration scope)))
            (text.enclosed ["{#loop " "}"]))
        
        {#Again args}
        (|> args
            (list#each %synthesis)
            (text.interposed " ")
            (text.enclosed ["{#again " "}"]))))

    {#Extension [[_ name] args]}
    (|> (list#each %synthesis args)
        (text.interposed " ")
        (format (%.text name) " ")
        (text.enclosed ["(" ")"]))))

(def .public %path
  (Format Path)
  (%path' %synthesis))

(def .public (path'_equivalence equivalence)
  (All (_ of)
    (-> (Equivalence of)
        (Equivalence (Path' of))))
  (implementation
   (def (= reference sample)
     (when [reference sample]
       [{#Pop} {#Pop}]
       true

       [{#Bit_Fork reference_when reference_then reference_else}
        {#Bit_Fork sample_when sample_then sample_else}]
       (and (bit#= reference_when sample_when)
            (= reference_then sample_then)
            (of (maybe.equivalence =) = reference_else sample_else))

       (^.with_template [<tag> <equivalence>]
         [[{<tag> reference_item}
           {<tag> sample_item}]
          (of (list.equivalence (product.equivalence <equivalence> =)) =
              {.#Item reference_item}
              {.#Item sample_item})])
       ([#I64_Fork (is (Equivalence I64) i64.equivalence)]
        [#F64_Fork f.equivalence]
        [#Text_Fork text.equivalence])
       
       (^.with_template [<tag> <equivalence>]
         [[{<tag> reference'} {<tag> sample'}]
          (of <equivalence> = reference' sample')])
       ([#Access /access.equivalence]
        [#Then   equivalence])
       
       [{#Bind reference'} {#Bind sample'}]
       (n.= reference' sample')

       (^.with_template [<tag>]
         [[{<tag> leftR rightR} {<tag> leftS rightS}]
          (and (= leftR leftS)
               (= rightR rightS))])
       ([#Alt]
        [#Seq])

       _
       false))))

(def (path'_hash super)
  (All (_ of)
    (-> (Hash of)
        (Hash (Path' of))))
  (implementation
   (def equivalence
     (..path'_equivalence (of super equivalence)))
   
   (def (hash value)
     (when value
       {#Pop}
       2

       {#Access access}
       (n.* 3 (of /access.hash hash access))

       {#Bind register}
       (n.* 5 (of n.hash hash register))

       {#Bit_Fork when then else}
       (all n.* 7
            (of bit.hash hash when)
            (hash then)
            (of (maybe.hash (path'_hash super)) hash else))

       (^.with_template [<factor> <tag> <hash>]
         [{<tag> item}
          (let [when_hash (product.hash <hash>
                                        (path'_hash super))
                item_hash (product.hash when_hash (list.hash when_hash))]
            (n.* <factor> (of item_hash hash item)))])
       ([11 #I64_Fork i64.hash]
        [13 #F64_Fork f.hash]
        [17 #Text_Fork text.hash])

       (^.with_template [<factor> <tag>]
         [{<tag> fork}
          (let [again_hash (path'_hash super)
                fork_hash (product.hash again_hash again_hash)]
            (n.* <factor> (of fork_hash hash fork)))])
       ([19 #Alt]
        [23 #Seq])

       {#Then body}
       (n.* 29 (of super hash body))
       ))))

(def (branch_equivalence (open "#[0]"))
  (All (_ of)
    (-> (Equivalence of)
        (Equivalence (Branch of))))
  (implementation
   (def (= reference sample)
     (when [reference sample]
       [{#Let [reference_input reference_register reference_body]}
        {#Let [sample_input sample_register sample_body]}]
       (and (#= reference_input sample_input)
            (n.= reference_register sample_register)
            (#= reference_body sample_body))

       [{#If [reference_test reference_then reference_else]}
        {#If [sample_test sample_then sample_else]}]
       (and (#= reference_test sample_test)
            (#= reference_then sample_then)
            (#= reference_else sample_else))
       
       [{#Get [reference_path reference_record]}
        {#Get [sample_path sample_record]}]
       (and (of (list.equivalence /member.equivalence) = reference_path sample_path)
            (#= reference_record sample_record))
       
       [{#When [reference_input reference_path]}
        {#When [sample_input sample_path]}]
       (and (#= reference_input sample_input)
            (of (path'_equivalence #=) = reference_path sample_path))
       
       _
       false))))

(def (branch_hash super)
  (All (_ of)
    (-> (Hash of)
        (Hash (Branch of))))
  (implementation
   (def equivalence
     (..branch_equivalence (of super equivalence)))
   
   (def (hash value)
     (when value
       {#Exec this that}
       (all n.* 2
            (of super hash this)
            (of super hash that))
       
       {#Let [input register body]}
       (all n.* 3
            (of super hash input)
            (of n.hash hash register)
            (of super hash body))

       {#If [test then else]}
       (all n.* 5
            (of super hash test)
            (of super hash then)
            (of super hash else))
       
       {#Get [path record]}
       (all n.* 7
            (of (list.hash /member.hash) hash path)
            (of super hash record))
       
       {#When [input path]}
       (all n.* 11
            (of super hash input)
            (of (..path'_hash super) hash path))
       ))))

(def (loop_equivalence (open "/#[0]"))
  (All (_ of)
    (-> (Equivalence of)
        (Equivalence (Loop of))))
  (implementation
   (def (= reference sample)
     (when [reference sample]
       [{#Scope [reference_start reference_inits reference_iteration]}
        {#Scope [sample_start sample_inits sample_iteration]}]
       (and (n.= reference_start sample_start)
            (of (list.equivalence /#=) = reference_inits sample_inits)
            (/#= reference_iteration sample_iteration))

       [{#Again reference} {#Again sample}]
       (of (list.equivalence /#=) = reference sample)
       
       _
       false))))

(def (loop_hash super)
  (All (_ of)
    (-> (Hash of)
        (Hash (Loop of))))
  (implementation
   (def equivalence
     (..loop_equivalence (of super equivalence)))
   
   (def (hash value)
     (when value
       {#Scope [start inits iteration]}
       (all n.* 2
            (of n.hash hash start)
            (of (list.hash super) hash inits)
            (of super hash iteration))

       {#Again resets}
       (all n.* 3
            (of (list.hash super) hash resets))
       ))))

(def (function_equivalence (open "#[0]"))
  (All (_ of)
    (-> (Equivalence of)
        (Equivalence (Function of))))
  (implementation
   (def (= reference sample)
     (when [reference sample]
       [{#Abstraction [reference_environment reference_arity reference_body]}
        {#Abstraction [sample_environment sample_arity sample_body]}]
       (and (of (list.equivalence #=) = reference_environment sample_environment)
            (n.= reference_arity sample_arity)
            (#= reference_body sample_body))
       
       [{#Apply [reference_abstraction reference_arguments]}
        {#Apply [sample_abstraction sample_arguments]}]
       (and (#= reference_abstraction sample_abstraction)
            (of (list.equivalence #=) = reference_arguments sample_arguments))
       
       _
       false))))

(def (function_hash super)
  (All (_ of)
    (-> (Hash of)
        (Hash (Function of))))
  (implementation
   (def equivalence
     (..function_equivalence (of super equivalence)))
   
   (def (hash value)
     (when value
       {#Abstraction [environment arity body]}
       (all n.* 2
            (of (list.hash super) hash environment)
            (of n.hash hash arity)
            (of super hash body))
       
       {#Apply [abstraction arguments]}
       (all n.* 3
            (of super hash abstraction)
            (of (list.hash super) hash arguments))
       ))))

(def (control_equivalence (open "#[0]"))
  (All (_ of)
    (-> (Equivalence of)
        (Equivalence (Control of))))
  (implementation
   (def (= reference sample)
     (when [reference sample]
       (^.with_template [<tag> <equivalence>]
         [[{<tag> reference} {<tag> sample}]
          (of (<equivalence> #=) = reference sample)])
       ([#Branch ..branch_equivalence]
        [#Loop ..loop_equivalence]
        [#Function ..function_equivalence])
       
       _
       false))))

(def (control_hash super)
  (All (_ of)
    (-> (Hash of)
        (Hash (Control of))))
  (implementation
   (def equivalence
     (..control_equivalence (of super equivalence)))

   (def (hash value)
     (when value
       (^.with_template [<factor> <tag> <hash>]
         [{<tag> value}
          (n.* <factor> (of (<hash> super) hash value))])
       ([2 #Branch ..branch_hash]
        [3 #Loop ..loop_hash]
        [5 #Function ..function_hash])
       ))))

(def .public equivalence
  (Equivalence Term)
  (implementation
   (def (= [_ reference] [_ sample])
     (when [reference sample]
       (^.with_template [<tag> <equivalence>]
         [[{<tag> reference'} {<tag> sample'}]
          (of <equivalence> = reference' sample')])
       ([#Simple /simple.equivalence]
        [#Structure (analysis/complex.equivalence =)]
        [#Reference reference.equivalence]
        [#Control (control_equivalence =)]
        [#Extension (extension.equivalence =)])

       _
       false))))

(def .public path_equivalence
  (Equivalence Path)
  (path'_equivalence equivalence))

(def .public hash
  (Hash Term)
  (implementation
   (def equivalence ..equivalence)

   (def (hash value)
     (let [again_hash [..equivalence hash]]
       (when value
         (^.with_template [<factor> <tag> <hash>]
           [[_ {<tag> value}]
            (n.* <factor> (of <hash> hash value))])
         ([02 #Simple /simple.hash]
          [03 #Structure (analysis/complex.hash again_hash)]
          [05 #Reference reference.hash]
          [07 #Control (..control_hash again_hash)]
          [11 #Extension (extension.hash again_hash)]))))))

(def .public !bind_top
  (template (!bind_top register thenP)
    [(all ..path/seq
          {..#Bind register}
          {..#Pop}
          thenP)]))

(def .public !multi_pop
  (template (!multi_pop nextP)
    [(all ..path/seq
          {..#Pop}
          {..#Pop}
          nextP)]))

... TODO: There are sister patterns to the simple side checks for tuples.
... These correspond to the situation where tuple members are accessed
... and bound to variables, but those variables are never used, so they
... become POPs.
... After re-implementing unused-variable-elimination, must add those
... pattern-optimizations again, since a lot of BINDs will become POPs
... and thus will result in useless code being translated.
(with_template [<name> <side>]
  [(def .public <name>
     (template (<name> idx nextP)
       [(all ..path/seq
             (<side> idx)
             {..#Pop}
             nextP)]))]

  [simple_left_side ..side/left]
  [simple_right_side ..side/right]
  )