(.using
 [library
  [lux (.except Definition Module type)
   ["[0]" meta]
   ["[0]" type (.open: "[1]#[0]" equivalence)]
   [abstract
    [monad (.only do)]
    ["[0]" enum]]
   [control
    ["[0]" maybe (.open: "[1]#[0]" functor)]
    ["[0]" exception (.only exception:)]
    ["<>" parser (.open: "[1]#[0]" monad)
     ["<[0]>" code (.only Parser)]]]
   [data
    ["[0]" product]
    ["[0]" text (.only \n) (.open: "[1]#[0]" order)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.open: "[1]#[0]" monad mix monoid)]
     ["[0]" set (.only Set)]
     ["[0]" stream (.only Stream)]]
    [format
     ["md" markdown (.only Markdown Block)]]]
   ["[0]" macro (.only)
    [syntax (.only syntax)]
    ["^" pattern]
    ["[0]" code]
    ["[0]" template]]
   [math
    [number
     ["n" nat]]]
   [tool
    [compiler
     [language
      [lux
       ["[0]" syntax]]]]]]])

(def |recursion_dummy|
  (template (_)
    [{.#Primitive "" {.#End}}]))

(type: Fragment
  (Variant
   {#Comment Text}
   {#Code Code}))

(def fragment
  (Parser Fragment)
  (<>.or <code>.text
         <code>.any))

(def (reference_column code)
  (-> Code Nat)
  (case code
    (^.with_template [<tag>]
      [[[_ _ column] {<tag> _}]
       column])
    ([.#Bit]
     [.#Nat]
     [.#Int]
     [.#Rev]
     [.#Frac]
     [.#Text]
     [.#Symbol])

    (^.with_template [<tag>]
      [[[_ _ column] {<tag> members}]
       (|> members
           (list#each reference_column)
           (list#mix n.min column))])
    ([.#Form]
     [.#Variant]
     [.#Tuple])
    ))

(def (padding reference_column [_ old_line old_column] [_ new_line new_column])
  (-> Nat Location Location Text)
  (if (n.= old_line new_line)
    (if (n.< old_column new_column)
      ""
      (text.together (list.repeated (n.- old_column new_column) " ")))
    (format (if (n.< old_line new_line)
              ""
              (text.together (list.repeated (n.- old_line new_line) \n)))
            (if (n.< reference_column new_column)
              ""
              (text.together (list.repeated (n.- reference_column new_column) " "))))))

(def (code_documentation expected_module old_location reference_column example)
  (-> Text Location Nat Code [Location Text])
  (case example
    [new_location {.#Symbol [module short]}]
    (let [documentation (cond (text#= expected_module module)
                              short

                              (text#= .prelude module)
                              (format "." short)
                              
                              ... else
                              (%.symbol [module short]))]
      [(revised .#column (n.+ (text.size documentation)) new_location)
       (format (padding reference_column old_location new_location)
               documentation)])
    
    (^.with_template [<tag> <format>]
      [[new_location {<tag> value}]
       (let [documentation (`` (|> value (~~ (template.spliced <format>))))]
         [(revised .#column (n.+ (text.size documentation)) new_location)
          (format (padding reference_column old_location new_location)
                  documentation)])])
    ([.#Bit [%.bit]]
     [.#Nat [%.nat]]
     [.#Int [%.int]]
     [.#Rev [%.rev]]
     [.#Frac [%.frac]]
     [.#Text [%.text]])

    (^.with_template [|<| |>| <tag>]
      [[group_location {<tag> members}]
       (let [[group_location' members_documentation] (list#mix (function (_ part [last_location text_accum])
                                                                 (let [[member_location member_documentation] (code_documentation expected_module last_location reference_column part)]
                                                                   [member_location (format text_accum member_documentation)]))
                                                               [(revised .#column ++ group_location) ""]
                                                               members)]
         [(revised .#column ++ group_location')
          (format (padding reference_column old_location group_location)
                  |<| members_documentation |>|)])])
    ([syntax.open_form    syntax.close_form    .#Form]
     [syntax.open_variant syntax.close_variant .#Variant]
     [syntax.open_tuple   syntax.close_tuple   .#Tuple])
    ))

(def blank_line
  Text
  (format \n \n))

(def single_line_comment
  (-> Text Text)
  (text.prefix "... "))

(def (fragment_documentation module fragment)
  (-> Text Fragment Text)
  (case fragment
    {#Comment comment}
    (..single_line_comment comment)

    {#Code example}
    (let [reference_column (..reference_column example)
          [location _] example]
      (|> example
          (..code_documentation module (has .#column reference_column location) reference_column)
          product.right))))

(def parameter_name_options "abcdefghijklmnopqrstuvwxyz")
(def parameter_name_options_count (text.size parameter_name_options))

(def (parameter_type_name id)
  (-> Nat Text)
  (format "_" (%.nat id))
  ... (case (text.char id ..parameter_name_options)
  ...   {.#Some char}
  ...   (text.of_char char)

  ...   {.#None}
  ...   (format (parameter_type_name (n./ parameter_name_options_count id))
  ...           (parameter_type_name (n.% parameter_name_options_count id))))
  )

(def type_variable_names
  (Stream Text)
  (stream.iterations (product.forked ++ parameter_type_name)
                     0))

(with_template [<name> <partition>]
  [(def (<name> id)
     (-> Nat Bit)
     (<partition> id))]

  [type_function? n.even?]
  [type_parameter? n.odd?]
  )

(def (parameter_id level id)
  (-> Nat Nat Nat)
  (n.- (n./ 2 id) level))

(def (parameter_name [type_function_name type_function_arguments] level id)
  (-> [Text (List Text)] Nat Nat Text)
  (if (type_parameter? id)
    (let [parameter_id (..parameter_id level id)]
      (case (list.item parameter_id type_function_arguments)
        {.#Some found}
        found

        _
        (let [parameter_id (n.- (list.size type_function_arguments) parameter_id)]
          (|> type_variable_names
              (stream.only (function (_ var_name)
                             (not (list.member? text.equivalence type_function_arguments var_name))))
              (stream.item parameter_id)))))      
    type_function_name))

(def (level_parameters offset level)
  (-> Nat Nat (List Text))
  (if (n.= 0 level)
    (list)
    (|> level
        --
        (enum.range n.enum 0)
        (list#each (|>> (n.+ (++ offset)) parameter_type_name)))))

(def (nested line_prefix body)
  (-> Text Text Text)
  (|> body
      (text.all_split_by \n)
      (list#each (text.prefix line_prefix))
      (text.interposed \n)))

(def (%type' level type_function_name nestable? module type)
  (-> Nat Text Bit Text Type Text)
  (case type
    {.#Primitive name params}
    (|> params
        (list#each (|>> (%type' level type_function_name false module)
                        (format " ")))
        {.#Item (%.text name)}
        text.together
        (text.enclosed ["(Primitive " ")"]))

    {.#Sum _}
    (|> type
        type.flat_variant
        (list#each (%type' level type_function_name false module))
        (text.interposed " ")
        (text.enclosed ["(Or " ")"]))

    {.#Product _}
    (|> type
        type.flat_tuple
        (list#each (%type' level type_function_name false module))
        (text.interposed " ")
        (text.enclosed ["[" "]"]))

    {.#Function input output}
    (let [[ins out] (type.flat_function type)]
      (format  "(-> "
               (|> ins (list#each (%type' level type_function_name false module)) (text.interposed " "))
               " "
               (%type' level type_function_name false module out)
               ")"))

    {.#Parameter idx}
    (parameter_name [type_function_name (list)] level idx)

    (^.with_template [<tag> <pre> <post>]
      [{<tag> id}
       (format <pre> (%.nat id) <post>)])
    ([.#Var "⌈" "⌋"]
     [.#Ex  "⟨" "⟩"])

    (^.with_template [<tag> <name> <flat>]
      [{<tag> _}
       (let [[level' body] (<flat> type)
             args (level_parameters level level')
             body_doc (%type' (n.+ level level') type_function_name nestable? module body)]
         (format "(" <name> " " "(_ " (|> args (text.interposed " ")) ")"
                 (if nestable?
                   (format \n (nested "  " body_doc))
                   (format " " body_doc))
                 ")"))])
    ([.#UnivQ "All" type.flat_univ_q]
     [.#ExQ   "Ex"  type.flat_ex_q])

    (pattern {.#Apply (|recursion_dummy|) {.#Parameter 0}})
    type_function_name

    (pattern {.#Apply (|recursion_dummy|) {.#UnivQ _ body}})
    (format "(Rec " type_function_name
            \n (nested " " (%type' level type_function_name nestable? module body))
            ")")

    {.#Apply param fun}
    (let [[type_func type_arguments] (type.flat_application type)]
      (format  "(" (%type' level type_function_name false module type_func)
               " " (|> type_arguments
                       (list#each (%type' level type_function_name false module))
                       (text.interposed " "))
               ")"))

    {.#Named [_module _name] type}
    (cond (text#= module _module)
          _name

          (text#= .prelude _module)
          (format "." _name)

          ... else
          (%.symbol [_module _name]))
    ))

(def type
  (-> Text Type Text)
  (%type' (-- 0) "?" true))

(def (parameterized_type arity type)
  (-> Nat Type (Maybe Type))
  (case arity
    0 {.#Some type}
    _ (case type
        {.#UnivQ _env _type}
        (parameterized_type (-- arity) _type)

        _
        {.#None})))

(def (type_definition' nestable? level arity type_function_info tags module type)
  (-> Bit Nat Nat [Text (List Text)] (List Text) Text Type Text)
  (case tags
    (pattern (list single_tag))
    (format "(Record" \n
            " [#" single_tag " " (type_definition' false level arity type_function_info {.#None} module type) "])")

    _
    (case type
      {.#Primitive name params}
      (case params
        {.#End}
        (format "(Primitive " (%.text name) ")")

        _
        (format "(Primitive " (%.text name) " " (|> params (list#each (type_definition' false level arity type_function_info {.#None} module)) (text.interposed " ")) ")"))

      {.#Sum _}
      (let [members (type.flat_variant type)]
        (case tags
          {.#End}
          (format "(Or "
                  (|> members
                      (list#each (type_definition' false level arity type_function_info {.#None} module))
                      (text.interposed " "))
                  ")")

          _
          (|> members
              (list.zipped_2 tags)
              (list#each (function (_ [t_name type])
                           (case type
                             {.#Product _}
                             (let [types (type.flat_tuple type)]
                               (format " {" t_name " "
                                       (|> types
                                           (list#each (type_definition' false level arity type_function_info {.#None} module))
                                           (text.interposed " "))
                                       "}"))

                             _
                             (format " {" t_name " " (type_definition' false level arity type_function_info {.#None} module type) "}"))))
              (text.interposed \n)
              (text.enclosed [(format "(Variant" \n) ")"]))))

      {.#Product _}
      (let [members (type.flat_tuple type)]
        (case tags
          {.#End}
          (format "[" (|> members (list#each (type_definition' false level arity type_function_info {.#None} module)) (text.interposed " ")) "]")

          _
          (|> members
              (list.zipped_2 tags)
              (list#each (function (_ [t_name type])
                           (format t_name " " (type_definition' false level arity type_function_info {.#None} module type))))
              (text.interposed (format \n "  "))
              (text.enclosed [" [" "]"])
              (text.enclosed [(format "(Record" \n) ")"]))))

      {.#Function input output}
      (let [[ins out] (type.flat_function type)]
        (format  "(-> " (|> ins (list#each (type_definition' false level arity type_function_info {.#None} module)) (text.interposed " "))
                 " "
                 (type_definition' false level arity type_function_info {.#None} module out)
                 ")"))

      {.#Parameter idx}
      (parameter_name type_function_info level idx)

      (^.with_template [<tag> <pre>]
        [{<tag> id}
         (format <pre> (%.nat id))])
      ([.#Var "-"]
       [.#Ex  "+"])

      (^.with_template [<tag> <name> <flat>]
        [{<tag> _}
         (let [[level' body] (<flat> type)
               args (level_parameters (n.- arity level) level')
               body_doc (type_definition' nestable? (n.+ level level') arity type_function_info tags module body)
               fn_name (case type_function_info
                         [fn_name {.#End}] fn_name
                         _ "_")]
           (format "(" <name> " " "(" fn_name " " (text.interposed " " args) ")"
                   (if nestable?
                     (format \n (..nested "  " body_doc))
                     (format " " body_doc))
                   ")"))])
      ([.#UnivQ "All" type.flat_univ_q]
       [.#ExQ   "Ex"  type.flat_ex_q])

      ... Recursive call
      (pattern {.#Apply (|recursion_dummy|) {.#Parameter 0}})
      (product.left type_function_info)

      (pattern {.#Apply (|recursion_dummy|) {.#UnivQ _ body}})
      (|> (type_definition' nestable? level arity type_function_info tags module body)
          (text.all_split_by \n)
          (list#each (text.prefix " "))
          (text.interposed \n)
          (text.enclosed [(format "(Rec " (product.left type_function_info) \n)
                          ")"]))

      {.#Apply param fun}
      (let [[type_func type_arguments] (type.flat_application type)]
        (format  "(" (type_definition' false level arity type_function_info tags module type_func)
                 " " (|> type_arguments
                         (list#each (type_definition' false level arity type_function_info {.#None} module))
                         (text.interposed " "))
                 ")"))

      {.#Named [_module _name] type}
      (cond (text#= module _module)
            _name

            (text#= .prelude _module)
            (format "." _name)

            ... else
            (%.symbol [_module _name]))
      )))

(def (type_definition module [name parameters] tags type)
  (-> Text [Text (List Text)] (List Text) Type Text)
  (let [arity (list.size parameters)]
    (case (parameterized_type arity type)
      {.#Some type}
      (type_definition' true (-- arity) arity [name parameters] tags module type)

      {.#None}
      (..type module type))))

(def description
  (Parser (Maybe Code))
  (<>.or (<code>.this_text "")
         <code>.any))

(exception: .public (unqualified_symbol [name Symbol])
  (exception.report
   "Name" (%.symbol name)))

(def qualified_symbol
  (Parser Symbol)
  (do <>.monad
    [name <code>.symbol]
    (case name
      ["" _]
      (<>.failure (exception.error ..unqualified_symbol [name]))
      
      _
      (in name))))

(def example_separator
  Code
  (let [c/01 "...."
        c/04 (format c/01 c/01 c/01 c/01)
        c_16 (format c/04 c/04 c/04 c/04)]
    (code.text (format blank_line
                       c_16 \n c_16
                       blank_line))))

(type: Example
  (List Fragment))

(def example
  (Parser Example)
  (<code>.tuple (<>.many ..fragment)))

(def (example_documentation module example)
  (-> Text Example Code)
  (|> example
      (list#each (..fragment_documentation module))
      (list.interposed ..blank_line)
      (text.interposed "")
      code.text))

(type: Declaration
  [Symbol (List Text)])

(def declaration
  (Parser Declaration)
  (<>.either (<>.and ..qualified_symbol (<>#in (list)))
             (<code>.form (<>.and ..qualified_symbol
                                  (<>.some (<code>.local))))))

(def minimal_definition_documentation
  (syntax (_ [[name parameters] ..declaration])
    (do meta.monad
      [.let [g!module (code.text (product.left name))]
       [[_ def_type def_value]] (meta.export name)
       tags (meta.tags_of name)]
      (with_expansions [<\n> (~! text.\n)]
        (macro.with_symbols [g!type]
          (in (list (` (all ((~! md.then))
                            ... Name
                            (<| ((~! md.heading/3))
                                (~ (code.text (%.code (let [g!name (|> name product.right code.local)]
                                                        (case parameters
                                                          {.#End}
                                                          g!name

                                                          _
                                                          (` ((~ g!name) (~+ (list#each code.local parameters))))))))))
                            ... Type
                            (let [(~ g!type) ("lux in-module"
                                              (~ g!module)
                                              (.type_of (~ (code.symbol name))))]
                              ((~! md.code) "clojure"
                               (~ (if (type#= .Type def_type)
                                    (` (|> (~ (code.symbol name))
                                           (as .Type)
                                           ((~! type.anonymous))
                                           ((~! ..type_definition)
                                            (~ g!module)
                                            [(~ (code.text (product.right name))) (list (~+ (list#each code.text parameters)))]
                                            (.list (~+ (|> tags
                                                           (maybe.else (list))
                                                           (list#each (|>> product.right code.text))))))
                                           ((~! %.format)
                                            ((~! ..single_line_comment) ((~! ..type) (~ g!module) (~ g!type)))
                                            <\n>)))
                                    (` ((~! ..type) (~ g!module) (~ g!type))))))))
                       ))))))))

(def definition_documentation
  (syntax (_ [[name parameters] ..declaration
              description ..description
              examples (<>.some ..example)])
    (with_expansions [<\n> (~! text.\n)]
      (in (list (` (all ((~! md.then))
                        ((~! ..minimal_definition_documentation)
                         ((~ (code.symbol name))
                          (~+ (list#each code.local parameters))))
                        ... Description
                        (~+ (case description
                              {.#Some description}
                              (list (` (<| ((~! md.paragraph))
                                           ((~! md.text))
                                           (~ description))))
                              
                              {.#None}
                              (list)))
                        ... Examples
                        (~+ (case examples
                              {.#End}
                              (list)
                              
                              _
                              (list (` (<| ((~! md.code) "clojure")
                                           ((~! %.format)
                                            (~+ (|> examples
                                                    (list#each (..example_documentation (product.left name)))
                                                    (list.interposed ..example_separator))))))))))
                   ))))))

(type: .public Definition
  (Record
   [#definition Text
    #documentation (Markdown Block)]))

(type: .public Module
  (Record
   [#module Text
    #description Text
    #expected (Set Text)
    #definitions (List Definition)]))

(def .public default
  (syntax (_ [[name parameters] ..declaration])
    (macro.with_symbols [g!_]
      (let [[_ short] name]
        (in (list (` (.let [(~ g!_) (.is (.-> .Any (.List ..Definition))
                                         (.function ((~ g!_) (~ g!_))
                                           (.list [..#definition (~ (code.text short))
                                                   ..#documentation ((~! ..minimal_definition_documentation)
                                                                     ((~ (code.symbol name))
                                                                      (~+ (list#each code.local parameters))))])))]
                       ((~ g!_) [])))))))))

(def .public documentation
  (syntax (_ [[name parameters] ..declaration
              extra (<>.some <code>.any)])
    (macro.with_symbols [g!_]
      (let [[_ short] name]
        (in (list (` (.let [(~ g!_) (.is (.-> .Any (.List ..Definition))
                                         (.function ((~ g!_) (~ g!_))
                                           (.list [..#definition (~ (code.text short))
                                                   ..#documentation ((~! ..definition_documentation)
                                                                     ((~ (code.symbol name))
                                                                      (~+ (list#each code.local parameters)))
                                                                     (~+ extra))])))]
                       ((~ g!_) [])))))))))

(def definitions_documentation
  (-> (List Definition) (Markdown Block))
  (|>> (list.sorted (function (_ left right)
                      (text#< (the #definition right)
                              (the #definition left))))
       (list#each (the #documentation))
       (list#mix md.then md.empty)))

(def expected_separator
  Text
  (text.of_char 31))

(def expected_format
  (-> (List Text) Text)
  (list#mix (function (_ short aggregate)
              (case aggregate
                "" short
                _ (format aggregate ..expected_separator short)))
            ""))

(def expected
  (-> Text (Set Text))
  (|>> (text.all_split_by ..expected_separator)
       (set.of_list text.hash)))

(def .public module
  (syntax (_ [[name _] ..qualified_symbol
              description <code>.any
              definitions (<code>.tuple (<>.some <code>.any))
              subs (<code>.tuple (<>.some <code>.any))])
    (do meta.monad
      [expected (meta.exports name)]
      (in (list (` (is (List Module)
                       ((~! list.partial) [..#module (~ (code.text name))
                                           ..#description (~ description)
                                           ..#expected ((~! ..expected)
                                                        (~ (code.text (|> expected
                                                                          (list#each product.left)
                                                                          ..expected_format))))
                                           ..#definitions ((~! list.together) (list (~+ definitions)))]
                        (all (at (~! list.monoid) (~' composite))
                             (is (List Module)
                                 (at (~! list.monoid) (~' identity)))
                             (~+ subs))))))))))

(def listing
  (-> (List Text) (Markdown Block))
  (|>> (list.sorted text#<)
       (list#each (function (_ definition)
                    [(md.snippet definition)
                     {.#None}]))
       md.numbered_list))

(def (module_documentation module)
  (-> Module (Markdown Block))
  (let [(open "_[0]") module]
    (all md.then
         ... Name
         (md.heading/1 (the #module module))
         ... Description
         (case (the #description module)
           "" md.empty
           description (<| md.paragraph
                           md.text
                           description))
         ... Definitions
         (md.heading/2 "Definitions")
         (|> module
             (the #definitions)
             (list.only (|>> (the #definition)
                             (set.member? _#expected)))
             ..definitions_documentation)
         ... Missing documentation
         (case (|> module
                   (the #definitions)
                   (list#mix (function (_ definition missing)
                               (set.lacks (the #definition definition) missing))
                             _#expected)
                   set.list)
           {.#End}
           md.empty

           missing
           (all md.then
                (md.heading/2 "Missing documentation")
                (..listing missing)))
         ... Un-expected documentation
         (case (|> module
                   (the #definitions)
                   (list.only (|>> (the #definition)
                                   (set.member? _#expected)
                                   not))
                   (list#each (the #definition)))
           {.#End}
           md.empty
           
           un_expected
           (all md.then
                (md.heading/2 "Un-expected documentation")
                (..listing un_expected)))
         )))

(def .public markdown
  (-> (List Module) Text)
  (|>> (list.sorted (function (_ left right)
                      (text#< (the #module right) (the #module left))))
       (list#each ..module_documentation)
       (list.interposed md.horizontal_rule)
       (list#mix md.then (is (Markdown Block) md.empty))
       md.markdown))