(.module:
  lux
  (lux (control [monad #+ do]
                ["ex" exception #+ exception:])
       (data [maybe]
             [product]
             ["e" error]
             [text "text/" Eq<Text>]
             text/format
             (coll [list]))
       [macro]
       (macro ["s" syntax #+ syntax:])
       (lang (type ["tc" check])))
  (luxc (lang ["la" analysis])))

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

(type: #export Analyser
  (-> Code (Meta la.Analysis)))

(def: #export version Text "0.6.0")

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

(def: #export (throw exception message)
  (All [a] (-> ex.Exception Text (Meta a)))
  (fail (exception message)))

(syntax: #export (assert exception message test)
  (wrap (list (` (if (~ test)
                   (:: macro.Monad<Meta> (~' wrap) [])
                   (..throw (~ exception) (~ message)))))))

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

      (#e.Error error)
      (#e.Error error))))

(def: #export (with-type-env action)
  (All [a] (-> (tc.Check a) (Meta a)))
  (function [compiler]
    (case (action (get@ #.type-context compiler))
      (#e.Error error)
      ((fail error) compiler)

      (#e.Success [context' output])
      (#e.Success [(set@ #.type-context context' compiler)
                   output]))))

(def: #export (with-fresh-type-env action)
  (All [a] (-> (Meta a) (Meta a)))
  (function [compiler]
    (let [old (get@ #.type-context compiler)]
      (case (action (set@ #.type-context tc.fresh-context compiler))
        (#e.Success [compiler' output])
        (#e.Success [(set@ #.type-context old compiler')
                     output])

        output
        output))))

(def: #export (infer actualT)
  (-> Type (Meta Unit))
  (do macro.Monad<Meta>
    [expectedT macro.expected-type]
    (with-type-env
      (tc.check expectedT actualT))))

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

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

(def: #export (pl-contains? key table)
  (All [a] (-> Text (List [Text a]) Bool))
  (case (pl-get key table)
    (#.Some _)
    true

    #.None
    false))

(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 (text/= key k')
      (#.Cons [key val]
              table')
      (#.Cons [k' v']
              (pl-put key val table')))))

(def: #export (pl-update key f table)
  (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a])))
  (case table
    #.Nil
    #.Nil

    (#.Cons [k' v'] table')
    (if (text/= key k')
      (#.Cons [k' (f v')] table')
      (#.Cons [k' v'] (pl-update key f table')))))

(def: #export (with-source-code source action)
  (All [a] (-> Source (Meta a) (Meta a)))
  (function [compiler]
    (let [old-source (get@ #.source compiler)]
      (case (action (set@ #.source source compiler))
        (#e.Error error)
        (#e.Error error)

        (#e.Success [compiler' output])
        (#e.Success [(set@ #.source old-source compiler')
                     output])))))

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

      (#e.Error error)
      (#e.Error (if (text/= "" error)
                  (handler [])
                  (format (handler []) "\n\n-----------------------------------------\n\n" 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] (-> (Meta a) (Meta [Scope a])))
  (function [compiler]
    (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler))
      (#e.Success [compiler' output])
      (case (get@ #.scopes compiler')
        #.Nil
        (#e.Error "Impossible error: Drained scopes!")

        (#.Cons head tail)
        (#e.Success [(set@ #.scopes tail compiler')
                     [head output]]))

      (#e.Error error)
      (#e.Error error))))

(def: #export (with-current-module name action)
  (All [a] (-> Text (Meta a) (Meta a)))
  (function [compiler]
    (case (action (set@ #.current-module (#.Some name) compiler))
      (#e.Success [compiler' output])
      (#e.Success [(set@ #.current-module
                         (get@ #.current-module compiler)
                         compiler')
                   output])

      (#e.Error error)
      (#e.Error error))))

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

          (#e.Error error)
          (#e.Error error))))))

(def: (normalize-char char)
  (-> Nat Text)
  (case char
    (^ (char "*")) "_ASTER_"
    (^ (char "+")) "_PLUS_"
    (^ (char "-")) "_DASH_"
    (^ (char "/")) "_SLASH_"
    (^ (char "\\")) "_BSLASH_"
    (^ (char "_")) "_UNDERS_"
    (^ (char "%")) "_PERCENT_"
    (^ (char "$")) "_DOLLAR_"
    (^ (char "'")) "_QUOTE_"
    (^ (char "`")) "_BQUOTE_"
    (^ (char "@")) "_AT_"
    (^ (char "^")) "_CARET_"
    (^ (char "&")) "_AMPERS_"
    (^ (char "=")) "_EQ_"
    (^ (char "!")) "_BANG_"
    (^ (char "?")) "_QM_"
    (^ (char ":")) "_COLON_"
    (^ (char ".")) "_PERIOD_"
    (^ (char ",")) "_COMMA_"
    (^ (char "<")) "_LT_"
    (^ (char ">")) "_GT_"
    (^ (char "~")) "_TILDE_"
    (^ (char "|")) "_PIPE_"
    _
    (text.from-code char)))

(def: underflow Nat (n/dec +0))

(def: #export (normalize-name name)
  (-> Text Text)
  (loop [idx (n/dec (text.size name))
         output ""]
    (if (n/= underflow idx)
      output
      (recur (n/dec idx) (format (|> (text.nth idx name) maybe.assume normalize-char) output)))))

(exception: #export Error)

(def: #export (with-error-tracking action)
  (All [a] (-> (Meta a) (Meta a)))
  (function [compiler]
    (case (action compiler)
      (#e.Error error)
      ((throw Error error) compiler)

      output
      output)))