(.module:
  [lux (#- nat int rev)
   [abstract
    ["." monad (#+ Monad do)]
    [equivalence (#+ Equivalence)]]
   [control
    ["p" parser]]
   [data
    ["." bit]
    ["." name]
    ["." maybe]
    ["." error (#+ Error)]
    [number
     ["." nat]
     ["." int]
     ["." rev]
     ["." frac]]
    ["." text ("#;." monoid)]
    [collection
     ["." list ("#;." functor)]]]]
  ["." // (#+ with-gensyms)
   ["." code ("#;." equivalence)]])

(def: (join-pairs pairs)
  (All [a] (-> (List [a a]) (List a)))
  (case pairs
    #.Nil                   #.Nil
    (#.Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))

(type: #export Syntax
  {#.doc "A Lux syntax parser."}
  (p.Parser (List Code)))

(def: (remaining-inputs asts)
  (-> (List Code) Text)
  ($_ text;compose text.new-line "Remaining input: "
      (|> asts (list;map code.to-text) (list.interpose " ") (text.join-with ""))))

(def: #export any
  {#.doc "Just returns the next input without applying any logic."}
  (Syntax Code)
  (function (_ tokens)
    (case tokens
      #.Nil                (#error.Failure "There are no tokens to parse!")
      (#.Cons [t tokens']) (#error.Success [tokens' t]))))

(template [<get-name> <type> <tag> <eq> <desc>]
  [(def: #export <get-name>
     {#.doc (code.text ($_ text;compose "Parses the next " <desc> " input Code."))}
     (Syntax <type>)
     (function (_ tokens)
       (case tokens
         (#.Cons [[_ (<tag> x)] tokens'])
         (#error.Success [tokens' x])

         _
         (#error.Failure ($_ text;compose "Cannot parse " <desc> (remaining-inputs tokens))))))]

  [   bit     Bit  #.Bit        bit.equivalence  "bit"]
  [   nat     Nat  #.Nat        nat.equivalence  "nat"]
  [   int     Int  #.Int        int.equivalence  "int"]
  [   rev     Rev  #.Rev        rev.equivalence  "rev"]
  [  frac     Frac #.Frac       frac.equivalence "frac"]
  [  text     Text #.Text       text.equivalence "text"]
  [identifier Name #.Identifier name.equivalence "identifier"]
  [   tag     Name #.Tag        name.equivalence "tag"]
  )

(def: #export (this? ast)
  {#.doc "Asks if the given Code is the next input."}
  (-> Code (Syntax Bit))
  (function (_ tokens)
    (case tokens
      (#.Cons [token tokens'])
      (let [is-it? (code;= ast token)
            remaining (if is-it?
                        tokens'
                        tokens)]
        (#error.Success [remaining is-it?]))

      _
      (#error.Success [tokens #0]))))

(def: #export (this ast)
  {#.doc "Ensures the given Code is the next input."}
  (-> Code (Syntax Any))
  (function (_ tokens)
    (case tokens
      (#.Cons [token tokens'])
      (if (code;= ast token)
        (#error.Success [tokens' []])
        (#error.Failure ($_ text;compose "Expected a " (code.to-text ast) " but instead got " (code.to-text token)
                            (remaining-inputs tokens))))

      _
      (#error.Failure "There are no tokens to parse!"))))

(template [<name> <tag> <desc>]
  [(def: #export <name>
     {#.doc (code.text ($_ text;compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
     (Syntax Text)
     (function (_ tokens)
       (case tokens
         (#.Cons [[_ (<tag> ["" x])] tokens'])
         (#error.Success [tokens' x])

         _
         (#error.Failure ($_ text;compose "Cannot parse local " <desc> (remaining-inputs tokens))))))]

  [local-identifier #.Identifier "identifier"]
  [   local-tag     #.Tag        "tag"]
  )

(template [<name> <tag> <desc>]
  [(def: #export (<name> p)
     {#.doc (code.text ($_ text;compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
     (All [a]
       (-> (Syntax a) (Syntax a)))
     (function (_ tokens)
       (case tokens
         (#.Cons [[_ (<tag> members)] tokens'])
         (case (p members)
           (#error.Success [#.Nil x]) (#error.Success [tokens' x])
           _                          (#error.Failure ($_ text;compose "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))

         _
         (#error.Failure ($_ text;compose "Cannot parse " <desc> (remaining-inputs tokens))))))]

  [ form  #.Form "form"]
  [tuple #.Tuple "tuple"]
  )

(def: #export (record p)
  {#.doc (code.text ($_ text;compose "Parse inside the contents of a record as if they were the input Codes."))}
  (All [a]
    (-> (Syntax a) (Syntax a)))
  (function (_ tokens)
    (case tokens
      (#.Cons [[_ (#.Record pairs)] tokens'])
      (case (p (join-pairs pairs))
        (#error.Success [#.Nil x]) (#error.Success [tokens' x])
        _                          (#error.Failure ($_ text;compose "Syntax was expected to fully consume record" (remaining-inputs tokens))))

      _
      (#error.Failure ($_ text;compose "Cannot parse record" (remaining-inputs tokens))))))

(def: #export end!
  {#.doc "Ensures there are no more inputs."}
  (Syntax Any)
  (function (_ tokens)
    (case tokens
      #.Nil (#error.Success [tokens []])
      _     (#error.Failure ($_ text;compose "Expected list of tokens to be empty!" (remaining-inputs tokens))))))

(def: #export end?
  {#.doc "Checks whether there are no more inputs."}
  (Syntax Bit)
  (function (_ tokens)
    (case tokens
      #.Nil (#error.Success [tokens #1])
      _     (#error.Success [tokens #0]))))

(def: #export (lift outcome)
  (All [a] (-> (Error a) (Syntax a)))
  (function (_ input)
    (case outcome
      (#error.Failure error)
      (#error.Failure error)

      (#error.Success value)
      (#error.Success [input value])
      )))

(def: #export (run inputs syntax)
  (All [a] (-> (List Code) (Syntax a) (Error a)))
  (case (syntax inputs)
    (#error.Failure error)
    (#error.Failure error)

    (#error.Success [unconsumed value])
    (case unconsumed
      #.Nil
      (#error.Success value)

      _
      (#error.Failure (text;compose "Unconsumed inputs: "
                                    (|> (list;map code.to-text unconsumed)
                                        (text.join-with ", ")))))))

(def: #export (local inputs syntax)
  {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
  (All [a] (-> (List Code) (Syntax a) (Syntax a)))
  (function (_ real)
    (do error.monad
      [value (run inputs syntax)]
      (wrap [real value]))))

(macro: #export (syntax: tokens)
  {#.doc (doc "A more advanced way to define macros than 'macro:'."
              "The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
              "The macro body is also (implicitly) run in the Meta monad, to save some typing."
              "Also, the compiler state can be accessed through the *compiler* binding."
              (syntax: #export (object {#let [imports (class-imports *compiler*)]}
                                 {#let [class-vars (list)]}
                                 {super (opt (super-class-decl^ imports class-vars))}
                                 {interfaces (tuple (some (super-class-decl^ imports class-vars)))}
                                 {constructor-args (constructor-args^ imports class-vars)}
                                 {methods (some (overriden-method-def^ imports))})
                (let [def-code ($_ text;compose "anon-class:"
                                   (spaced (list (super-class-decl$ (maybe.default object-super-class super))
                                                 (with-brackets (spaced (list;map super-class-decl$ interfaces)))
                                                 (with-brackets (spaced (list;map constructor-arg$ constructor-args)))
                                                 (with-brackets (spaced (list;map (method-def$ id) methods))))))]
                  (wrap (list (` ((~ (code.text def-code)))))))))}
  (let [[exported? tokens] (: [Bit (List Code)]
                              (case tokens
                                (^ (list& [_ (#.Tag ["" "export"])] tokens'))
                                [#1 tokens']

                                _
                                [#0 tokens]))
        ?parts (: (Maybe [Text (List Code) Code Code])
                  (case tokens
                    (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
                             body))
                    (#.Some name args (` {}) body)

                    (^ (list [_ (#.Form (list& [_ (#.Identifier ["" name])] args))]
                             meta-data
                             body))
                    (#.Some name args meta-data body)

                    _
                    #.None))]
    (case ?parts
      (#.Some [name args meta body])
      (with-gensyms [g!tokens g!body g!error]
        (do //.monad
          [vars+parsers (monad.map @
                                   (: (-> Code (Meta [Code Code]))
                                      (function (_ arg)
                                        (case arg
                                          (^ [_ (#.Record (list [var parser]))])
                                          (wrap [var parser])

                                          [_ (#.Identifier var-name)]
                                          (wrap [(code.identifier var-name) (` (~! any))])

                                          _
                                          (//.fail "Syntax pattern expects records or identifiers."))))
                                   args)
           this-module //.current-module-name
           #let [g!state (code.identifier ["" "*compiler*"])
                 error-msg (code.text (//.wrong-syntax-error [this-module name]))
                 export-ast (: (List Code)
                               (if exported?
                                 (list (' #export))
                                 (list)))]]
          (wrap (list (` (macro: (~+ export-ast) ((~ (code.identifier ["" name])) (~ g!tokens) (~ g!state))
                           (~ meta)
                           ({(#error.Success (~ g!body))
                             ((~ g!body) (~ g!state))

                             (#error.Failure (~ g!error))
                             (#error.Failure ((~! text.join-with) ": " (list (~ error-msg) (~ g!error))))}
                            ((~! ..run) (~ g!tokens)
                             (: ((~! ..Syntax) (Meta (List Code)))
                                ((~! do) (~! p.monad)
                                 [(~+ (join-pairs vars+parsers))]
                                 ((~' wrap) ((~! do) (~! //.monad)
                                             []
                                             (~ body)))))))))))))
      
      _
      (//.fail (//.wrong-syntax-error (name-of ..syntax:))))))