path: root/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux

(.using
 [library
  [lux "*"
   [abstract
    [equivalence (.only Equivalence)]
    ["[0]" monad (.only do)]]
   [control
    ["[0]" pipe]]
   [data
    ["[0]" product]
    ["[0]" bit ("[1]#[0]" equivalence)]
    ["[0]" text ("[1]#[0]" equivalence)]
    [collection
     ["[0]" list ("[1]#[0]" functor mix monoid)]
     ["[0]" set (.only Set)]]]
   [macro
    ["^" pattern]]
   [math
    [number
     ["n" nat]
     ["[0]" i64]
     ["[0]" frac]]]]]
 ["[0]" /// "_"
  [//
   ["[1][0]" analysis (.only Match Analysis)
    ["[2][0]" simple]
    ["[2][0]" complex]
    ["[2][0]" pattern (.only Pattern)]]
   ["/" synthesis (.only Path Synthesis Operation Phase)
    ["[1][0]" access
     ["[2][0]" side]
     ["[2][0]" member (.only Member)]]]
   [///
    ["[1]" phase ("[1]#[0]" monad)]
    ["[1][0]" reference
     ["[1]/[0]" variable (.only Register Variable)]]
    [meta
     [archive (.only Archive)]]]]])

(def: clean_up
  (-> Path Path)
  (|>> {/.#Seq {/.#Pop}}))

(def: (path' pattern end? thenC)
  (-> Pattern Bit (Operation Path) (Operation Path))
  (case pattern
    {///pattern.#Simple simple}
    (case simple
      {///simple.#Unit}
      thenC

      {///simple.#Bit when}
      (///#each (function (_ then)
                  {/.#Bit_Fork when then {.#None}})
                thenC)

      (^.template [<from> <to> <conversion>]
        [{<from> test}
         (///#each (function (_ then)
                     {<to> [(<conversion> test) then] (list)})
                   thenC)])
      ([///simple.#Nat  /.#I64_Fork .i64]
       [///simple.#Int  /.#I64_Fork .i64]
       [///simple.#Rev  /.#I64_Fork .i64]
       [///simple.#Frac /.#F64_Fork |>]
       [///simple.#Text /.#Text_Fork |>]))

    {///pattern.#Bind register}
    (<| (# ///.monad each (|>> {/.#Seq {/.#Bind register}}))
        /.with_new_local
        thenC)

    {///pattern.#Complex {///complex.#Variant [lefts right? value_pattern]}}
    (<| (///#each (|>> {/.#Seq {/.#Access {/access.#Side [/side.#lefts lefts
                                                          /side.#right? right?]}}}))
        (path' value_pattern end?)
        (pipe.when [(pipe.new (not end?) [])] [(///#each ..clean_up)])
        thenC)

    {///pattern.#Complex {///complex.#Tuple tuple}}
    (let [tuple::last (-- (list.size tuple))]
      (list#mix (function (_ [tuple::lefts tuple::member] nextC)
                  (.case tuple::member
                    {///pattern.#Simple {///simple.#Unit}}
                    nextC

                    _
                    (let [right? (n.= tuple::last tuple::lefts)
                          end?' (and end? right?)]
                      (<| (///#each (|>> {/.#Seq {/.#Access {/access.#Member [/member.#lefts (if right?
                                                                                               (-- tuple::lefts)
                                                                                               tuple::lefts)
                                                                              /member.#right? right?]}}}))
                          (path' tuple::member end?')
                          (pipe.when [(pipe.new (not end?') [])] [(///#each ..clean_up)])
                          nextC))))
                thenC
                (list.reversed (list.enumeration tuple))))
    ))

(def: (path archive synthesize pattern bodyA)
  (-> Archive Phase Pattern Analysis (Operation Path))
  (path' pattern true (///#each (|>> {/.#Then}) (synthesize archive bodyA))))

(def: (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail])
  (All (_ a)
    (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path)
        (/.Fork a Path)))
  (if (# equivalence = new_test old_test)
    [[old_test (weave new_then old_then)] old_tail]
    [[old_test old_then]
     (case old_tail
       {.#End}
       (list [new_test new_then])
       
       {.#Item old_item}
       {.#Item (weave_branch weave equivalence [new_test new_then] old_item)})]))

(def: (weave_fork weave equivalence new_fork old_fork)
  (All (_ a)
    (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path)
        (/.Fork a Path)))
  (list#mix (..weave_branch weave equivalence) old_fork {.#Item new_fork}))

(def: (weave new old)
  (-> Path Path Path)
  (with_expansions [<default> (these {/.#Alt old new})]
    (case [new old]
      [_
       {/.#Alt old_left old_right}]
      {/.#Alt old_left
              (weave new old_right)}

      [{/.#Seq preN postN}
       {/.#Seq preO postO}]
      (case (weave preN preO)
        {/.#Alt _}
        <default>

        woven
        {/.#Seq woven (weave postN postO)})

      [{/.#Pop} {/.#Pop}]
      old

      [{/.#Bit_Fork new_when new_then new_else}
       {/.#Bit_Fork old_when old_then old_else}]
      (if (bit#= new_when old_when)
        {/.#Bit_Fork old_when
                     (weave new_then old_then)
                     (case [new_else old_else]
                       [{.#None} {.#None}]
                       {.#None}

                       (^.or [{.#Some woven_then} {.#None}]
                             [{.#None} {.#Some woven_then}])
                       {.#Some woven_then}

                       [{.#Some new_else} {.#Some old_else}]
                       {.#Some (weave new_else old_else)})}
        {/.#Bit_Fork old_when
                     (case new_else
                       {.#None}
                       old_then

                       {.#Some new_else}
                       (weave new_else old_then))
                     {.#Some (case old_else
                               {.#None}
                               new_then

                               {.#Some old_else}
                               (weave new_then old_else))}})

      (^.template [<tag> <equivalence>]
        [[{<tag> new_fork} {<tag> old_fork}]
         {<tag> (..weave_fork weave <equivalence> new_fork old_fork)}])
      ([/.#I64_Fork i64.equivalence]
       [/.#F64_Fork frac.equivalence]
       [/.#Text_Fork text.equivalence])
      
      (^.template [<access> <side> <lefts> <right?>]
        [[{/.#Access {<access> [<lefts> newL <right?> <side>]}}
          {/.#Access {<access> [<lefts> oldL <right?> <side>]}}]
         (if (n.= newL oldL)
           old
           <default>)])
      ([/access.#Side #0 /side.#lefts /side.#right?]
       [/access.#Side #1 /side.#lefts /side.#right?]

       [/access.#Member #0 /member.#lefts /member.#right?]
       [/access.#Member #1 /member.#lefts /member.#right?])

      [{/.#Bind newR} {/.#Bind oldR}]
      (if (n.= newR oldR)
        old
        <default>)

      _
      <default>)))

(def: (get patterns @selection)
  (-> (///complex.Tuple Pattern) Register (List Member))
  (loop (again [lefts 0
                patterns patterns])
    (with_expansions [<failure> (these (list))
                      <continue> (these (again (++ lefts)
                                               tail))
                      <member> (these (let [right? (list.empty? tail)]
                                        [/member.#lefts (if right?
                                                          (-- lefts)
                                                          lefts)
                                         /member.#right? right?]))]
      (case patterns
        {.#End}
        <failure>

        {.#Item head tail}
        (case head
          {///pattern.#Simple {///simple.#Unit}}
          <continue>
          
          {///pattern.#Bind register}
          (if (n.= @selection register)
            (list <member>)
            <continue>)

          {///pattern.#Complex {///complex.#Tuple sub_patterns}}
          (case (get sub_patterns @selection)
            {.#End}
            <continue>

            sub_members
            (partial_list <member> sub_members))
          
          _
          <failure>)))))

(def: .public (synthesize_case synthesize archive input [[headP headA] tailPA+])
  (-> Phase Archive Synthesis Match (Operation Synthesis))
  (do [! ///.monad]
    [headSP (path archive synthesize headP headA)
     tailSP+ (monad.each ! (product.uncurried (path archive synthesize)) tailPA+)]
    (in (/.branch/case [input (list#mix weave headSP tailSP+)]))))

(template: (!masking <variable> <output>)
  [[[{///pattern.#Bind <variable>}
     {///analysis.#Reference (///reference.local <output>)}]
    (list)]])

(def: .public (synthesize_exec synthesize archive before after)
  (-> Phase Archive Synthesis Analysis (Operation Synthesis))
  (do ///.monad
    [after (synthesize archive after)]
    (in (/.branch/exec [before after]))))

(def: .public (synthesize_let synthesize archive input @variable body)
  (-> Phase Archive Synthesis Register Analysis (Operation Synthesis))
  (do ///.monad
    [body (/.with_new_local
            (synthesize archive body))]
    (in (/.branch/let [input @variable body]))))

(def: .public (synthesize_masking synthesize archive input @variable @output)
  (-> Phase Archive Synthesis Register Register (Operation Synthesis))
  (if (n.= @variable @output)
    (///#in input)
    (..synthesize_let synthesize archive input @variable {///analysis.#Reference (///reference.local @output)})))

(def: .public (synthesize_if synthesize archive test then else)
  (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis))
  (do ///.monad
    [then (synthesize archive then)
     else (synthesize archive else)]
    (in (/.branch/if [test then else]))))

(template: (!get <patterns> <output>)
  [[[(///pattern.tuple <patterns>)
     {///analysis.#Reference (///reference.local <output>)}]
    (.list)]])

(def: .public (synthesize_get synthesize archive input patterns @member)
  (-> Phase Archive Synthesis (///complex.Tuple Pattern) Register (Operation Synthesis))
  (case (..get patterns @member)
    {.#End}
    (..synthesize_case synthesize archive input (!get patterns @member))

    path
    (case input
      (pattern (/.branch/get [sub_path sub_input]))
      (///#in (/.branch/get [(list#composite path sub_path) sub_input]))

      _
      (///#in (/.branch/get [path input])))))

(def: .public (synthesize synthesize^ [headB tailB+] archive inputA)
  (-> Phase Match Phase)
  (do [! ///.monad]
    [inputS (synthesize^ archive inputA)]
    (case [headB tailB+]
      (pattern (!masking @variable @output))
      (..synthesize_masking synthesize^ archive inputS @variable @output)

      (pattern [[(///pattern.unit) body]
                {.#End}])
      (case inputA
        (^.or {///analysis.#Simple _}
              {///analysis.#Structure _}
              {///analysis.#Reference _})
        (synthesize^ archive body)

        _
        (..synthesize_exec synthesize^ archive inputS body))

      [[{///pattern.#Bind @variable} body]
       {.#End}]
      (..synthesize_let synthesize^ archive inputS @variable body)
      
      (^.or (pattern [[(///pattern.bit #1) then]
                      (list [(///pattern.bit #0) else])])
            (pattern [[(///pattern.bit #1) then]
                      (list [(///pattern.unit) else])])

            (pattern [[(///pattern.bit #0) else]
                      (list [(///pattern.bit #1) then])])
            (pattern [[(///pattern.bit #0) else]
                      (list [(///pattern.unit) then])]))
      (..synthesize_if synthesize^ archive inputS then else)
      
      (pattern (!get patterns @member))
      (..synthesize_get synthesize^ archive inputS patterns @member)
      
      match
      (..synthesize_case synthesize^ archive inputS match))))

(def: .public (count_pops path)
  (-> Path [Nat Path])
  (case path
    (pattern (/.path/seq {/.#Pop} path'))
    (let [[pops post_pops] (count_pops path')]
      [(++ pops) post_pops])

    _
    [0 path]))

(def: .public pattern_matching_error
  "Invalid expression for pattern-matching.")

(type: .public Storage
  (Record
   [#bindings (Set Register)
    #dependencies (Set Variable)]))

(def: empty
  Storage
  [#bindings (set.empty n.hash)
   #dependencies (set.empty ///reference/variable.hash)])

... TODO: Use this to declare all local variables at the beginning of
... script functions.
... That way, it should be possible to do cheap "let" expressions,
... since the variable will exist beforehand, so no closure will need
... to be created for it.
... Apply this trick to JS, Python et al.
(def: .public (storage path)
  (-> Path Storage)
  (loop (for_path [path path
                   path_storage ..empty])
    (case path
      (^.or {/.#Pop}
            {/.#Access Access})
      path_storage

      (pattern (/.path/bind register))
      (revised #bindings (set.has register)
               path_storage)

      {/.#Bit_Fork _ default otherwise}
      (|> (case otherwise
            {.#None}
            path_storage
            
            {.#Some otherwise}
            (for_path otherwise path_storage))
          (for_path default))

      (^.or {/.#I64_Fork forks}
            {/.#F64_Fork forks}
            {/.#Text_Fork forks})
      (|> {.#Item forks}
          (list#each product.right)
          (list#mix for_path path_storage))

      (^.or (pattern (/.path/seq left right))
            (pattern (/.path/alt left right)))
      (list#mix for_path path_storage (list left right))

      (pattern (/.path/then bodyS))
      (loop (for_synthesis [bodyS bodyS
                            synthesis_storage path_storage])
        (case bodyS
          (^.or {/.#Simple _}
                (pattern (/.constant _)))
          synthesis_storage
          
          (pattern (/.variant [lefts right? valueS]))
          (for_synthesis valueS synthesis_storage)

          (pattern (/.tuple members))
          (list#mix for_synthesis synthesis_storage members)

          {/.#Reference {///reference.#Variable {///reference/variable.#Local register}}}
          (if (set.member? (the #bindings synthesis_storage) register)
            synthesis_storage
            (revised #dependencies (set.has {///reference/variable.#Local register}) synthesis_storage))

          {/.#Reference {///reference.#Variable var}}
          (revised #dependencies (set.has var) synthesis_storage)

          (pattern (/.function/apply [functionS argsS]))
          (list#mix for_synthesis synthesis_storage {.#Item functionS argsS})

          (pattern (/.function/abstraction [environment arity bodyS]))
          (list#mix for_synthesis synthesis_storage environment)

          (pattern (/.branch/case [inputS pathS]))
          (revised #dependencies
                   (set.union (the #dependencies (for_path pathS synthesis_storage)))
                   (for_synthesis inputS synthesis_storage))

          (pattern (/.branch/exec [before after]))
          (list#mix for_synthesis synthesis_storage (list before after))

          (pattern (/.branch/let [inputS register exprS]))
          (revised #dependencies
                   (set.union (|> synthesis_storage
                                  (revised #bindings (set.has register))
                                  (for_synthesis exprS)
                                  (the #dependencies)))
                   (for_synthesis inputS synthesis_storage))

          (pattern (/.branch/if [testS thenS elseS]))
          (list#mix for_synthesis synthesis_storage (list testS thenS elseS))

          (pattern (/.branch/get [access whole]))
          (for_synthesis whole synthesis_storage)

          (pattern (/.loop/scope [start initsS+ iterationS]))
          (revised #dependencies
                   (set.union (|> synthesis_storage
                                  (revised #bindings (set.union (|> initsS+
                                                                    list.enumeration
                                                                    (list#each (|>> product.left (n.+ start)))
                                                                    (set.of_list n.hash))))
                                  (for_synthesis iterationS)
                                  (the #dependencies)))
                   (list#mix for_synthesis synthesis_storage initsS+))

          (pattern (/.loop/again replacementsS+))
          (list#mix for_synthesis synthesis_storage replacementsS+)

          {/.#Extension [extension argsS]}
          (list#mix for_synthesis synthesis_storage argsS)))
      )))