(;module:
  lux
  (lux (control functor
                applicative
                monad
                ["p" parser])
       (data (coll [list "L/" Monoid<List> Monad<List>])
             [text "T/" Monoid<Text>]
             text/format
             ["R" result]
             [sum])
       [io]
       [macro #+ with-gensyms Functor<Lux> Monad<Lux>]
       (macro [code]
              ["s" syntax #+ syntax: Syntax])))

## [Types]
(type: #export CLI
  {#;doc "A command-line interface parser."}
  (p;Parser (List Text)))

## [Combinators]
(def: #export (run inputs parser)
  (All [a] (-> (List Text) (CLI a) (R;Result a)))
  (case (p;run inputs parser)
    (#R;Success [remaining output])
    (case remaining
      #;Nil
      (#R;Success output)

      _
      (#R;Error (format "Remaining CLI inputs: " (text;join-with " " remaining))))

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

(def: #export any
  {#;doc "Just returns the next input without applying any logic."}
  (CLI Text)
  (function [inputs]
    (case inputs
      (#;Cons arg inputs')
      (#R;Success [inputs' arg])
      
      _
      (#R;Error "Cannot parse empty arguments."))))

(def: #export (parse parser)
  {#;doc "Parses the next input with a parsing function."}
  (All [a] (-> (-> Text (R;Result a)) (CLI a)))
  (function [inputs]
    (case inputs
      (#;Cons arg inputs')
      (case (parser arg)
        (#R;Success value)
        (#R;Success [inputs' value])

        (#R;Error parser-error)
        (#R;Error parser-error))
      
      _
      (#R;Error "Cannot parse empty arguments."))))

(def: #export (option names)
  {#;doc "Checks that a given option (with multiple possible names) has a value."}
  (-> (List Text) (CLI Text))
  (function [inputs]
    (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
      (case post
        #;Nil
        (#R;Error ($_ T/append "Missing option (" (text;join-with " " names) ")"))

        (^ (list& _ value post'))
        (#R;Success [(L/append pre post') value])

        _
        (#R;Error ($_ T/append "Option lacks value (" (text;join-with " " names) ")"))
        ))))

(def: #export (flag names)
  {#;doc "Checks that a given flag (with multiple possible names) is set."}
  (-> (List Text) (CLI Bool))
  (function [inputs]
    (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
      (case post
        #;Nil
        (#R;Success [pre false])

        (#;Cons _ post')
        (#R;Success [(L/append pre post') true])))))

(def: #export end
  {#;doc "Ensures there are no more inputs."}
  (CLI Unit)
  (function [inputs]
    (case inputs
      #;Nil (#R;Success [inputs []])
      _     (#R;Error (T/append "Unknown parameters: " (text;join-with " " inputs))))))

## [Syntax]
(type: Program-Args
  (#Raw Text)
  (#Parsed (List [Code Code])))

(def: program-args^
  (Syntax Program-Args)
  (p;alt s;local-symbol
         (s;form (p;some (p;either (do p;Monad<Parser>
                                     [name s;local-symbol]
                                     (wrap [(code;symbol ["" name]) (` any)]))
                                   (s;tuple (p;seq s;any s;any)))))))

(syntax: #export (program: [args program-args^] body)
  {#;doc (doc "Defines the entry-point to a program (similar to the \"main\" function/method in other programming languages)."
              "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module."
              (program: all-args
                (do Monad<IO>
                  [foo init-program
                   bar (do-something all-args)]
                  (wrap [])))

              (program: (name)
                (io (log! (T/append "Hello, " name))))

              (program: ([config config^])
                (do Monad<IO>
                  [data (init-program config)]
                  (do-something data))))}
  (case args
    (#Raw args)
    (wrap (list (` (;_lux_program (~ (code;symbol ["" args]))
                                  (do io;Monad<IO>
                                    []
                                    (~ body))))))
    
    (#Parsed args)
    (with-gensyms [g!args g!_ g!output g!message]
      (wrap (list (` (;_lux_program (~ g!args)
                                    (case ((: (;;CLI (io;IO Unit))
                                              (do ;;Monad<CLI>
                                                [(~@ (|> args
                                                         (L/map (function [[binding parser]]
                                                                  (list binding parser)))
                                                         L/join))
                                                 (~ g!_) ;;end]
                                                ((~' wrap) (do io;Monad<IO>
                                                             []
                                                             (~ body)))))
                                           (~ g!args))
                                      (#R;Success [(~ g!_) (~ g!output)])
                                      (~ g!output)

                                      (#R;Error (~ g!message))
                                      (error! (~ g!message))
                                      )))
                  )))
    ))