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

(.require
 [library
  [lux (.except Tuple Variant Pattern Analysis #Function #Apply nat int rev when local except)
   [abstract
    [equivalence (.only Equivalence)]
    [hash (.only Hash)]
    [monad (.only do)]]
   [control
    ["[0]" function]
    ["[0]" maybe]
    ["[0]" try (.only Try)]
    ["[0]" exception (.only Exception)]]
   [data
    ["[0]" product]
    ["[0]" bit (.use "[1]#[0]" equivalence)]
    ["[0]" text (.use "[1]#[0]" equivalence)
     ["%" \\format (.only Format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]]]
   [math
    [number
     ["n" nat]
     ["i" int]
     ["r" rev]
     ["f" frac]]]
   [meta
    ["[0]" location]
    ["[0]" configuration (.only Configuration)]
    ["[0]" code
     ["<[1]>" \\parser]]
    [macro
     [syntax (.only syntax)]]]]]
 ["[0]" /
  ["[1][0]" simple (.only Simple)]
  ["[1][0]" complex (.only Tuple Variant Complex)]
  ["[1][0]" pattern (.only Pattern)]
  [//
   [phase
    ["[0]" extension (.only Extension)]]
   [///
    [arity (.only Arity)]
    ["[0]" version (.only Version)]
    ["[0]" phase]
    ["[0]" reference (.only Reference)
     ["[0]" variable (.only Register Variable)]]]]])

(type .public (Branch' e)
  (Record
   [#when Pattern
    #then e]))

(type .public (Match' e)
  [(Branch' e) (List (Branch' e))])

(type .public (Environment a)
  (List a))

(type .public Analysis
  (Rec Analysis
    (.Variant
     {#Simple Simple}
     {#Structure (Complex Analysis)}
     {#Reference Reference}
     {#When Analysis (Match' Analysis)}
     {#Function (Environment Analysis) Analysis}
     {#Apply Analysis Analysis}
     {#Extension (Extension Analysis)})))

(type .public Branch
  (Branch' Analysis))

(type .public Match
  (Match' Analysis))

(def (branch_equivalence equivalence)
  (-> (Equivalence Analysis) (Equivalence Branch))
  (implementation
   (def (= [reference_pattern reference_body] [sample_pattern sample_body])
     (and (at /pattern.equivalence = reference_pattern sample_pattern)
          (at equivalence = reference_body sample_body)))))

(def .public equivalence
  (Equivalence Analysis)
  (implementation
   (def (= reference sample)
     (.when [reference sample]
       [{#Simple reference} {#Simple sample}]
       (at /simple.equivalence = reference sample)

       [{#Structure reference} {#Structure sample}]
       (at (/complex.equivalence =) = reference sample)

       [{#Reference reference} {#Reference sample}]
       (at reference.equivalence = reference sample)

       [{#When [reference_analysis reference_match]}
        {#When [sample_analysis sample_match]}]
       (and (= reference_analysis sample_analysis)
            (at (list.equivalence (branch_equivalence =)) = {.#Item reference_match} {.#Item sample_match}))

       [{#Function [reference_environment reference_analysis]}
        {#Function [sample_environment sample_analysis]}]
       (and (= reference_analysis sample_analysis)
            (at (list.equivalence =) = reference_environment sample_environment))

       [{#Apply [reference_input reference_abstraction]}
        {#Apply [sample_input sample_abstraction]}]
       (and (= reference_input sample_input)
            (= reference_abstraction sample_abstraction))

       [{#Extension reference} {#Extension sample}]
       (at (extension.equivalence =) = reference sample)

       _
       false))))

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

  [when ..#When]
  )

(def .public unit
  (template (unit)
    [{..#Simple {/simple.#Unit}}]))

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

  [bit  /simple.#Bit]
  [nat  /simple.#Nat]
  [int  /simple.#Int]
  [rev  /simple.#Rev]
  [frac /simple.#Frac]
  [text /simple.#Text]
  )

(type .public (Abstraction c)
  [(Environment c) Arity c])

(type .public (Reification c)
  [c (List c)])

(def .public no_op
  (template (no_op value)
    [(|> 1
         {variable.#Local}
         {reference.#Variable}
         {..#Reference}
         {..#Function (list)}
         {..#Apply value})]))

(def .public (reified [abstraction inputs])
  (-> (Reification Analysis) Analysis)
  (list#mix (function (_ input abstraction')
              {#Apply input abstraction'})
            abstraction
            inputs))

(def .public (reification analysis)
  (-> Analysis (Reification Analysis))
  (loop (again [abstraction analysis
                inputs (is (List Analysis)
                           (list))])
    (.when abstraction
      {#Apply input next}
      (again next {.#Item input inputs})

      _
      [abstraction inputs])))

(with_template [<name> <tag>]
  [(def .public <name>
     (syntax (_ [content <code>.any])
       (in (list (` (.<| {..#Reference}
                         <tag>
                         (, content)))))))]

  [variable {reference.#Variable}]
  [constant {reference.#Constant}]

  [local    reference.local]
  [foreign  reference.foreign]
  )

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

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

(def .public (format analysis)
  (Format Analysis)
  (.when analysis
    {#Simple it}
    (/simple.format it)
    
    {#Structure it}
    (/complex.format format it)
    
    {#Reference reference}
    (reference.format reference)
    
    {#When analysis match}
    (%.format "({"
              (|> {.#Item match}
                  (list#each (function (_ [when then])
                               (%.format (/pattern.format when) " " (format then))))
                  (text.interposed " "))
              "} "
              (format analysis)
              ")")
    
    {#Function environment body}
    (|> (format body)
        (%.format " ")
        (%.format (|> environment
                      (list#each format)
                      (text.interposed " ")
                      (text.enclosed ["[" "]"])))
        (text.enclosed ["(" ")"]))
    
    {#Apply _}
    (|> analysis
        ..reification
        {.#Item}
        (list#each format)
        (text.interposed " ")
        (text.enclosed ["(" ")"]))
    
    {#Extension name parameters}
    (|> parameters
        (list#each format)
        (text.interposed " ")
        (%.format (%.symbol name) " ")
        (text.enclosed ["(" ")"]))))

(type .public State
  Lux)

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

(type .public Phase
  (phase.Phase State Code Analysis))

(with_template [<special> <general>]
  [(type .public <special>
     (<general> State Code Analysis))]

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

(def .public (with_source_code source action)
  (All (_ a) (-> Source (Operation a) (Operation a)))
  (function (_ state)
    (let [old_source (the .#source state)]
      (.when (action (has .#source source state))
        {try.#Success [state' output]}
        {try.#Success [(has .#source old_source state')
                       output]}

        failure
        failure))))

(def .public (with_current_module name)
  (All (_ a) (-> Text (Operation a) (Operation a)))
  (phase.localized (the .#current_module)
                   (has .#current_module)
                   (function.constant {.#Some name})))

(def .public (with_location location action)
  (All (_ a) (-> Location (Operation a) (Operation a)))
  (if (text#= "" (product.left location))
    action
    (function (_ state)
      (let [old_location (the .#location state)]
        (.when (action (has .#location location state))
          {try.#Success [state' output]}
          {try.#Success [(has .#location old_location state')
                         output]}

          failure
          failure)))))

(def (located location error)
  (-> Location Text Text)
  (%.format (%.location location) text.new_line
            error))

(def .public (failure error)
  (-> Text Operation)
  (function (_ state)
    {try.#Failure (located (the .#location state) error)}))

(def .public (of_try it)
  (All (_ a) (-> (Try a) (Operation a)))
  (function (_ state)
    (.when it
      {try.#Failure error}
      {try.#Failure (located (the .#location state) error)}

      {try.#Success it}
      {try.#Success [state it]})))

(def .public (except exception parameters)
  (All (_ e) (-> (Exception e) e Operation))
  (..failure (exception.error exception parameters)))

(def .public (assertion exception parameters condition)
  (All (_ e) (-> (Exception e) e Bit (Operation Any)))
  (if condition
    (at phase.monad in [])
    (..except exception parameters)))

(def .public (with_exception exception message action)
  (All (_ e o) (-> (Exception e) e (Operation o) (Operation o)))
  (function (_ state)
    (.when (exception.with exception message
             (action state))
      {try.#Failure error}
      {try.#Failure (located (the .#location state) error)}

      success
      success)))

(def .public (set_state state)
  (-> .Lux (Operation Any))
  (function (_ _)
    {try.#Success [state []]}))

(with_template [<name> <type> <field> <value>]
  [(def .public (<name> value)
     (-> <type> (Operation Any))
     (phase.update (has <field> <value>)))]

  [set_source_code    Source   .#source         value]
  [set_current_module Text     .#current_module {.#Some value}]
  [set_location       Location .#location       value]
  )

(def .public (location file)
  (-> Text Location)
  [file 1 0])

(def .public (source file code)
  (-> Text Text Source)
  [(location file) 0 code])

(def dummy_source
  Source
  [location.dummy 0 ""])

(def type_context
  Type_Context
  [.#ex_counter 0
   .#var_counter 0
   .#var_bindings (list)])

(def .public (info version host configuration)
  (-> Version Text Configuration Info)
  [.#target host
   .#version (version.format version)
   .#mode {.#Build}
   .#configuration configuration])

(def .public (state info)
  (-> Info Lux)
  [.#info            info
   .#source          ..dummy_source
   .#location        location.dummy
   .#current_module  {.#None}
   .#modules         (list)
   .#scopes          (list)
   .#type_context    ..type_context
   .#expected        {.#None}
   .#seed            0
   .#scope_type_vars (list)
   .#extensions      []
   .#eval            (as (-> Type Code (Meta Any)) [])
   .#host            []])