path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/when.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 Pattern)
   [abstract
    [equivalence (.only Equivalence)]
    ["[0]" monad (.only do)]]
   [control
    ["[0]" pipe]]
   [data
    ["[0]" product]
    ["[0]" bit (.use "[1]#[0]" equivalence)]
    ["[0]" text (.use "[1]#[0]" equivalence)]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix monoid)]
     ["[0]" set (.only Set)]]]
   [math
    [number
     ["n" nat]
     ["[0]" i64]
     ["[0]" frac]]]
   [meta
    [macro
     ["^" pattern]]]]]
 ["[0]" ///
  [//
   ["[0]" phase (.use "[1]#[0]" monad)]
   ["[0]" analysis (.only Match)
    ["[2][0]" simple]
    ["[2][0]" complex]
    ["[2][0]" pattern (.only Pattern)]]
   ["/" synthesis (.only Path Operation Phase)
    ["[1][0]" access (.only)
     ["[2][0]" side]
     ["[2][0]" member (.only Member)]]]
   [///
    ["[1][0]" reference (.only)
     ["[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))
  (when pattern
    {///pattern.#Simple simple}
    (when simple
      {///simple.#Unit}
      thenC

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

      (^.with_template [<from> <to> <conversion>]
        [{<from> test}
         (phase#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}
    (<| (of phase.monad each (|>> {/.#Seq {/.#Bind register}}))
        /.with_new_local
        thenC)

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

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

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

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

(def (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail])
  (All (_ of)
    (-> (-> Path Path Path) (Equivalence of) [of Path] (/.Fork of Path)
        (/.Fork of Path)))
  (if (of equivalence = new_test old_test)
    [[old_test (weave new_then old_then)] old_tail]
    [[old_test old_then]
     (when 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 (_ of)
    (-> (-> Path Path Path) (Equivalence of) (/.Fork of Path) (/.Fork of Path)
        (/.Fork of 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})]
    (when [new old]
      [_
       {/.#Alt old_left old_right}]
      {/.#Alt old_left
              (weave new old_right)}

      [{/.#Seq preN postN}
       {/.#Seq preO postO}]
      (when (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)
                     (when [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
                     (when new_else
                       {.#None}
                       old_then

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

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

      (^.with_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])
      
      (^.with_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 .false /side.#lefts /side.#right?]
       [/access.#Side .true /side.#lefts /side.#right?]

       [/access.#Member .false /member.#lefts /member.#right?]
       [/access.#Member .true /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?]))]
      (when patterns
        {.#End}
        <failure>

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

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

            sub_members
            (list.partial <member> sub_members))
          
          _
          <failure>)))))

(def .public (synthesize_when synthesize @ archive input [[headP headA] tailPA+])
  (-> Phase Location Archive /.Term Match
      (Operation /.Term))
  (do [! phase.monad]
    [headSP (path archive synthesize headP headA)
     tailSP+ (monad.each ! (product.uncurried (path archive synthesize)) tailPA+)]
    (in (/.branch/when @ [input (list#mix weave headSP tailSP+)]))))

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

(def .public (synthesize_exec synthesize @ archive before after)
  (-> Phase Location Archive /.Term analysis.Term
      (Operation /.Term))
  (do phase.monad
    [after (synthesize archive after)]
    (in (/.branch/exec @ [before after]))))

(def .public (synthesize_let synthesize @ archive input @variable body)
  (-> Phase Location Archive /.Term Register analysis.Term
      (Operation /.Term))
  (do phase.monad
    [body (/.with_new_local
            (synthesize archive body))]
    (in (/.branch/let @ [[@variable input] body]))))

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

(def .public (synthesize_if synthesize @ archive test then else)
  (-> Phase Location Archive /.Term analysis.Term analysis.Term
      (Operation /.Term))
  (do phase.monad
    [then (synthesize archive then)
     else (synthesize archive else)]
    (in (/.branch/if @ [test then else]))))

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

(def .public (synthesize_get synthesize @ archive input patterns @member)
  (-> Phase Location Archive /.Term (///complex.Tuple Pattern) Register
      (Operation /.Term))
  (when (..get patterns @member)
    {.#End}
    (..synthesize_when synthesize @ archive input (!get @ patterns @member))

    path
    (phase#in (when input
                (/.branch/get @ [sub_path sub_input])
                (/.branch/get @ [(list#composite sub_path path) sub_input])

                _
                (/.branch/get @ [path input])))))

(def .public (synthesize @ synthesize^ [headB tailB+] archive inputA)
  (-> Location Phase Match
      Phase)
  (do [! phase.monad]
    [inputS (synthesize^ archive inputA)]
    (when [headB tailB+]
      (!masking @ @variable @output)
      (..synthesize_masking synthesize^ @ archive inputS @variable @output)

      [[(///pattern.unit) body]
       {.#End}]
      (when 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.bit .true) then]
             (list [(///pattern.bit .false) else])]
            [[(///pattern.bit .true) then]
             (list [(///pattern.unit) else])]

            [[(///pattern.bit .false) else]
             (list [(///pattern.bit .true) then])]
            [[(///pattern.bit .false) else]
             (list [(///pattern.unit) then])])
      (..synthesize_if synthesize^ @ archive inputS then else)
      
      (!get @ patterns @member)
      (..synthesize_get synthesize^ @ archive inputS patterns @member)
      
      match
      (..synthesize_when synthesize^ @ archive inputS match))))

(def .public (count_pops path)
  (-> Path
      [Nat Path])
  (when path
    (/.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])
    (when path
      (^.or {/.#Pop}
            {/.#Access Access})
      path_storage

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

      {/.#Bit_Fork _ default otherwise}
      (|> (when 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 (/.path/seq left right)
            (/.path/alt left right))
      (list#mix for_path path_storage (list left right))

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

          (/.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)

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

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

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

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

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

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

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

          (/.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+))

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

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