(;module:
  lux
  (lux (control monad)
       (data [text "T/" Eq<Text>]
             text/format
             [product]
             ["R" result])
       [macro #+ Monad<Lux>]
       (type ["TC" check]))
  (luxc (lang ["la" analysis])))

(type: #export Eval
  (-> Type Code (Lux Top)))

(type: #export Analyser
  (-> Code (Lux la;Analysis)))

(type: #export Path Text)

(type: #export Mode
  #Build
  #Eval
  #REPL)

(def: #export (fail message)
  (All [a] (-> Text (Lux a)))
  (do Monad<Lux>
    [[file line col] macro;cursor
     #let [location (format file
                            "," (|> line nat-to-int %i)
                            "," (|> col nat-to-int %i))]]
    (macro;fail (format "@ " location
                        "\n" message))))

(def: #export (with-expected-type expected action)
  (All [a] (-> Type (Lux a) (Lux a)))
  (function [compiler]
    (case (action (set@ #;expected (#;Some expected) compiler))
      (#R;Success [compiler' output])
      (let [old-expected (get@ #;expected compiler)]
        (#R;Success [(set@ #;expected old-expected compiler')
                     output]))

      (#R;Error error)
      (#R;Error error))))

(def: #export (within-type-env action)
  (All [a] (-> (TC;Check a) (Lux a)))
  (function [compiler]
    (case (action (get@ #;type-context compiler))
      (#R;Error error)
      (#R;Error error)

      (#R;Success [context' output])
      (#R;Success [(set@ #;type-context context' compiler)
                   output]))))

(def: #export (pl-contains? key mappings)
  (All [a] (-> Text (List [Text a]) Bool))
  (case mappings
    #;Nil
    false

    (#;Cons [k v] mappings')
    (or (T/= key k)
        (pl-contains? key mappings'))))

(def: #export (pl-put key val table)
  (All [a] (-> Text a (List [Text a]) (List [Text a])))
  (case table
    #;Nil
    (list [key val])

    (#;Cons [k' v'] table')
    (if (T/= key k')
      (#;Cons [key val]
              table')
      (#;Cons [k' v']
              (pl-put key val table')))))

(def: #export (pl-get key table)
  (All [a] (-> Text (List [Text a]) (Maybe a)))
  (case table
    #;Nil
    #;None

    (#;Cons [k' v'] table')
    (if (T/= key k')
      (#;Some v')
      (pl-get key table'))))

(def: #export (with-source-code source action)
  (All [a] (-> [Cursor Text] (Lux a) (Lux a)))
  (function [compiler]
    (let [old-source (get@ #;source compiler)]
      (case (action (set@ #;source source compiler))
        (#R;Error error)
        (#R;Error error)

        (#R;Success [compiler' output])
        (#R;Success [(set@ #;source old-source compiler')
                     output])))))

(def: #export (with-stacked-errors handler action)
  (All [a] (-> (-> [] Text) (Lux a) (Lux a)))
  (function [compiler]
    (case (action compiler)
      (#R;Success [compiler' output])
      (#R;Success [compiler' output])

      (#R;Error error)
      (#R;Error (if (T/= "" error)
                  (handler [])
                  (format error "\n-----------------------------------------\n" (handler [])))))))

(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] (-> (Lux a) (Lux [Scope a])))
  (function [compiler]
    (case (action (update@ #;scopes (|>. (#;Cons fresh-scope)) compiler))
      (#R;Success [compiler' output])
      (case (get@ #;scopes compiler')
        #;Nil
        (#R;Error "Impossible error: Drained scopes!")

        (#;Cons head tail)
        (#R;Success [(set@ #;scopes tail compiler')
                     [head output]]))

      (#R;Error error)
      (#R;Error error))))

(def: #export (with-cursor cursor action)
  (All [a] (-> Cursor (Lux a) (Lux a)))
  (if (T/= "" (product;left cursor))
    action
    (function [compiler]
      (let [old-cursor (get@ #;cursor compiler)]
        (case (action (set@ #;cursor cursor compiler))
          (#R;Success [compiler' output])
          (#R;Success [(set@ #;cursor old-cursor compiler')
                       output])

          (#R;Error error)
          (#R;Error error))))))