path: root/stdlib/source/lux/tool/compiler/language/lux/analysis.lux

(.module:
  [lux (#- nat int rev)
   [abstract
    [monad (#+ do)]]
   [control
    ["." function]
    ["." try]
    ["." exception (#+ Exception)]]
   [data
    ["." product]
    ["." maybe]
    [number
     ["n" nat]]
    ["." text ("#@." equivalence)
     ["%" format (#+ Format format)]]
    [collection
     ["." list ("#@." functor fold)]]]]
  [//
   [phase
    ["." extension (#+ Extension)]]
   [///
    [arity (#+ Arity)]
    ["." reference (#+ Register Variable Reference)]
    ["." phase]]])

(type: #export #rec Primitive
  #Unit
  (#Bit Bit)
  (#Nat Nat)
  (#Int Int)
  (#Rev Rev)
  (#Frac Frac)
  (#Text Text))

(type: #export Tag Nat)

(type: #export (Variant a)
  {#lefts Nat
   #right? Bit
   #value a})

(type: #export (Tuple a) (List a))

(type: #export (Composite a)
  (#Variant (Variant a))
  (#Tuple (Tuple a)))

(type: #export #rec Pattern
  (#Simple Primitive)
  (#Complex (Composite Pattern))
  (#Bind Register))

(type: #export (Branch' e)
  {#when Pattern
   #then e})

(type: #export (Match' e)
  [(Branch' e) (List (Branch' e))])

(type: #export Environment
  (List Variable))

(type: #export #rec Analysis
  (#Primitive Primitive)
  (#Structure (Composite Analysis))
  (#Reference Reference)
  (#Case Analysis (Match' Analysis))
  (#Function Environment Analysis)
  (#Apply Analysis Analysis)
  (#Extension (Extension Analysis)))

(type: #export Branch
  (Branch' Analysis))

(type: #export Match
  (Match' Analysis))

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

  [control/case #..Case]
  )

(template [<name> <type> <tag>]
  [(template: #export (<name> value)
     (#..Primitive (<tag> value)))]

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

(type: #export (Abstraction c) [Environment Arity c])

(type: #export (Application c) [c (List c)])

(def: (last? size tag)
  (-> Nat Tag Bit)
  (n.= (dec size) tag))

(template: #export (no-op value)
  (|> 1 #reference.Local #reference.Variable #..Reference
      (#..Function (list))
      (#..Apply value)))

(def: #export (apply [abstraction inputs])
  (-> (Application Analysis) Analysis)
  (list@fold (function (_ input abstraction')
               (#Apply input abstraction'))
             abstraction
             inputs))

(def: #export (application analysis)
  (-> Analysis (Application Analysis))
  (loop [abstraction analysis
         inputs (list)]
    (case abstraction
      (#Apply input next)
      (recur next (#.Cons input inputs))

      _
      [abstraction inputs])))

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

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

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

(template [<name> <tag>]
  [(template: #export (<name> content)
     (.<| #..Complex
          <tag>
          content))]

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

(template [<name> <tag>]
  [(template: #export (<name> content)
     (.<| #..Structure
          <tag>
          content))]

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

(template: #export (pattern/unit)
  (#..Simple #..Unit))

(template [<name> <tag>]
  [(template: #export (<name> content)
     (#..Simple (<tag> content)))]
  
  [pattern/bit  #..Bit]
  [pattern/nat  #..Nat]
  [pattern/int  #..Int]
  [pattern/rev  #..Rev]
  [pattern/frac #..Frac]
  [pattern/text #..Text]
  )

(template: #export (pattern/bind register)
  (#..Bind register))

(def: #export (%analysis analysis)
  (Format Analysis)
  (case analysis
    (#Primitive primitive)
    (case primitive
      #Unit
      "[]"

      (^template [<tag> <format>]
        (<tag> value)
        (<format> value))
      ([#Bit %.bit]
       [#Nat %.nat]
       [#Int %.int]
       [#Rev %.rev]
       [#Frac %.frac]
       [#Text %.text]))
    
    (#Structure structure)
    (case structure
      (#Variant [lefts right? value])
      (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")")
      
      (#Tuple members)
      (|> members
          (list@map %analysis)
          (text.join-with " ")
          (text.enclose ["[" "]"])))
    
    (#Reference reference)
    (case reference
      (#reference.Variable variable)
      (reference.%variable variable)
      
      (#reference.Constant constant)
      (%.name constant))
    
    (#Case analysis match)
    "{?}"
    
    (#Function environment body)
    (|> (%analysis body)
        (format " ")
        (format (|> environment
                    (list@map reference.%variable)
                    (text.join-with " ")
                    (text.enclose ["[" "]"])))
        (text.enclose ["(" ")"]))
    
    (#Apply _)
    (|> analysis
        ..application
        #.Cons
        (list@map %analysis)
        (text.join-with " ")
        (text.enclose ["(" ")"]))
    
    (#Extension name parameters)
    (|> parameters
        (list@map %analysis)
        (text.join-with " ")
        (format (%.text name) " ")
        (text.enclose ["(" ")"]))))

(template [<special> <general>]
  [(type: #export <special>
     (<general> .Lux Code Analysis))]

  [State+    extension.State]
  [Operation extension.Operation]
  [Phase     extension.Phase]
  [Handler   extension.Handler]
  [Bundle    extension.Bundle]
  )

(def: #export (with-source-code source action)
  (All [a] (-> Source (Operation a) (Operation a)))
  (function (_ [bundle state])
    (let [old-source (get@ #.source state)]
      (case (action [bundle (set@ #.source source state)])
        (#try.Success [[bundle' state'] output])
        (#try.Success [[bundle' (set@ #.source old-source state')]
                       output])

        (#try.Failure error)
        (#try.Failure error)))))

(def: fresh-bindings
  (All [k v] (Bindings k v))
  {#.counter 0
   #.mappings (list)})

(def: fresh-scope
  Scope
  {#.name     (list)
   #.inner    0
   #.locals   fresh-bindings
   #.captured fresh-bindings})

(def: #export (with-scope action)
  (All [a] (-> (Operation a) (Operation [Scope a])))
  (function (_ [bundle state])
    (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) state)])
      (#try.Success [[bundle' state'] output])
      (case (get@ #.scopes state')
        (#.Cons head tail)
        (#try.Success [[bundle' (set@ #.scopes tail state')]
                       [head output]])

        #.Nil
        (#try.Failure "Impossible error: Drained scopes!"))

      (#try.Failure error)
      (#try.Failure error))))

(def: #export (with-current-module name)
  (All [a] (-> Text (Operation a) (Operation a)))
  (extension.localized (get@ #.current-module)
                       (set@ #.current-module)
                       (function.constant (#.Some name))))

(def: #export (with-cursor cursor action)
  (All [a] (-> Cursor (Operation a) (Operation a)))
  (if (text@= "" (product.left cursor))
    action
    (function (_ [bundle state])
      (let [old-cursor (get@ #.cursor state)]
        (case (action [bundle (set@ #.cursor cursor state)])
          (#try.Success [[bundle' state'] output])
          (#try.Success [[bundle' (set@ #.cursor old-cursor state')]
                         output])

          (#try.Failure error)
          (#try.Failure error))))))

(def: (locate-error cursor error)
  (-> Cursor Text Text)
  (format "@ " (%.cursor cursor) text.new-line
          error))

(def: #export (fail error)
  (-> Text Operation)
  (function (_ [bundle state])
    (#try.Failure (locate-error (get@ #.cursor state) error))))

(def: #export (throw exception parameters)
  (All [e] (-> (Exception e) e Operation))
  (..fail (exception.construct exception parameters)))

(def: #export (assert exception parameters condition)
  (All [e] (-> (Exception e) e Bit (Operation Any)))
  (if condition
    (:: phase.monad wrap [])
    (..throw exception parameters)))

(def: #export (fail' error)
  (-> Text (phase.Operation Lux))
  (function (_ state)
    (#try.Failure (locate-error (get@ #.cursor state) error))))

(def: #export (throw' exception parameters)
  (All [e] (-> (Exception e) e (phase.Operation Lux)))
  (..fail' (exception.construct exception parameters)))

(def: #export (with-stack exception message action)
  (All [e o] (-> (Exception e) e (Operation o) (Operation o)))
  (function (_ bundle,state)
    (case (exception.with exception message
            (action bundle,state))
      (#try.Success output)
      (#try.Success output)
      
      (#try.Failure error)
      (let [[bundle state] bundle,state]
        (#try.Failure (locate-error (get@ #.cursor state) error))))))

(template [<name> <type> <field> <value>]
  [(def: #export (<name> value)
     (-> <type> (Operation Any))
     (extension.update (set@ <field> <value>)))]

  [set-source-code    Source #.source         value]
  [set-current-module Text   #.current-module (#.Some value)]
  [set-cursor         Cursor #.cursor         value]
  )

(def: #export (cursor file)
  (-> Text Cursor)
  [file 1 0])

(def: #export (source file code)
  (-> Text Text Source)
  [(cursor file) 0 code])

(def: dummy-source
  Source
  [.dummy-cursor 0 ""])

(def: type-context
  Type-Context
  {#.ex-counter 0
   #.var-counter 0
   #.var-bindings (list)})

(def: #export (state info host)
  (-> Info Any Lux)
  {#.info            info
   #.source          ..dummy-source
   #.cursor          .dummy-cursor
   #.current-module  #.None
   #.modules         (list)
   #.scopes          (list)
   #.type-context    ..type-context
   #.expected        #.None
   #.seed            0
   #.scope-type-vars (list)
   #.extensions      []
   #.host            host})