(;module:
  lux
  (lux (control monad)
       (data [bool]
             [char]
             [text]
             [number]
             (text ["l" lexer #+ Lexer Monad<Lexer> "l/" Monad<Lexer>]
                   format)
             [product]
             (coll [list "L/" Functor<List> Fold<List>]
                   ["V" vector]))))

(def: (space^ where)
  (-> Cursor (Lexer [Text Cursor]))
  (do Monad<Lexer>
    [head (l;some' (l;one-of "\t\v \r\f"))]
    (l;either (l;after (l;one-of "\n")
                       (do @
                         [[tail end] (space^ (|> where
                                                 (update@ #;line n.inc)
                                                 (set@ #;column +0)))]
                         (wrap [(format head tail)
                                end])))
              (wrap [head
                     (|> where
                         (update@ #;column (n.+ (text;size head))))]))))

(def: (single-line-comment^ where)
  (-> Cursor (Lexer [Text Cursor]))
  (l;enclosed ["##" "\n"]
              (do Monad<Lexer>
                [comment (l;some' (l;none-of "\n"))]
                (wrap [comment
                       (|> where
                           (update@ #;line n.inc)
                           (set@ #;column +0))]))))

(def: comment-bound^
  (Lexer Text)
  ($_ l;either
      (l;text "\n")
      (l;text ")#")
      (l;text "#(")))

(def: (multi-line-comment^ where)
  (-> Cursor (Lexer [Text Cursor]))
  (do Monad<Lexer>
    [_ (l;text "#(")
     [comment end] (loop [comment ""
                          where (|> where
                                    (update@ #;column (n.+ +2)))]
                     ($_ l;either
                         (do @
                           [_ (l;one-of "\n")]
                           (recur (format comment "\n")
                                  (|> where
                                      (update@ #;line n.inc)
                                      (set@ #;column +0))))
                         (do @
                           [chunk (l;some' (l;not comment-bound^))]
                           (recur (format comment chunk)
                                  (|> where
                                      (update@ #;column (n.+ (text;size chunk))))))
                         (do @
                           [[sub-comment sub-where] (multi-line-comment^ where)]
                           (wrap [(format comment "#(" sub-comment ")#")
                                  sub-where]))))
     _ (l;text ")#")]
    (wrap [comment
           (|> end
               (update@ #;column (n.+ +2)))])))

(def: (comment^ where)
  (-> Cursor (Lexer [Text Cursor]))
  (l;either (single-line-comment^ where)
            (multi-line-comment^ where)))

(def: escaped-char^
  (Lexer [Text Char])
  (l;after (l;char #"\\")
           (do Monad<Lexer>
             [code l;any]
             (case code
               #"t" (wrap ["\\t" #"\t"])
               #"v" (wrap ["\\v" #"\v"])
               #"b" (wrap ["\\b" #"\b"])
               #"n" (wrap ["\\n" #"\n"])
               #"r" (wrap ["\\r" #"\r"])
               #"f" (wrap ["\\f" #"\f"])
               #"\"" (wrap ["\\\"" #"\""])
               #"\\" (wrap ["\\\\" #"\\"])

               #"u"
               (do Monad<Lexer>
                 [code (l;between' +1 +4 l;hex-digit)]
                 (wrap (case (:: number;Hex@Codec<Text,Nat> decode
                                 (format "+" code))
                         (#;Right value)
                         [(format "\\u" code) (char;char value)]

                         _
                         (undefined))))

               _
               (l;fail (format "Invalid escaping syntax: " (%c code)))))))

(def: raw-char^
  (Lexer [Text Char])
  (l;either (do Monad<Lexer>
              [char (l;none-of "\\\"\n")]
              (wrap [(char;as-text char) char]))
            escaped-char^))

(do-template [<name> <tag> <lexer> <codec>]
  [(def: (<name> where)
     (-> Cursor (Lexer [AST Cursor]))
     (do Monad<Lexer>
       [chunk <lexer>]
       (case (:: <codec> decode chunk)
         (#;Left error)
         (l;fail error)

         (#;Right value)
         (wrap [[where (<tag> value)]
                (|> where
                    (update@ #;column (n.+ (text;size chunk))))]))))]

  [bool^ #;BoolS
   (l;either (l;text "true") (l;text "false"))
   bool;Codec<Text,Bool>]
  [nat^ #;NatS
   (l;seq' (l;text "+") (l;many' l;digit))
   number;Codec<Text,Nat>]
  [int^ #;IntS
   (l;seq' (l;default "" (l;text "-"))
           (l;many' l;digit))
   number;Codec<Text,Int>]
  [real^ #;RealS
   ($_ l;seq'
       (l;default "" (l;text "-"))
       (l;many' l;digit)
       (l;text ".")
       (l;many' l;digit))
   number;Codec<Text,Real>]
  [deg^ #;DegS
   (l;seq' (l;text ".")
           (l;many' l;digit))
   number;Codec<Text,Deg>]
  )

(def: (char^ where)
  (-> Cursor (Lexer [AST Cursor]))
  (do Monad<Lexer>
    [[chunk value] (l;enclosed ["#\"" "\""]
                               raw-char^)]
    (wrap [[where (#;CharS value)]
           (|> where
               (update@ #;column (function [column]
                                   ($_ n.+
                                       +3
                                       column
                                       (text;size chunk)))))])))

(def: (text^ where)
  (-> Cursor (Lexer [AST Cursor]))
  (do Monad<Lexer>
    [_ (l;text "\"")
     #let [offset-column (n.inc (get@ #;column where))]
     [text-read where'] (: (Lexer [Text Cursor])
                           (loop [text-read ""
                                  where (|> where
                                            (update@ #;column n.inc))
                                  next-line-start? false]
                             (let [next-line (do @
                                               [_ (l;text "\n")]
                                               (recur text-read
                                                      (|> where
                                                          (update@ #;line n.inc)
                                                          (set@ #;column +0))
                                                      true))]
                               (if next-line-start?
                                 (l;either next-line
                                           (do @
                                             [offset (l;many' (l;char #" "))
                                              #let [offset-size (text;size offset)]]
                                             (if (n.>= offset-column offset-size)
                                               (recur (|> offset
                                                          (text;split offset-column)
                                                          (default (undefined))
                                                          product;right
                                                          (format text-read))
                                                      (|> where
                                                          (update@ #;column (n.+ offset-size)))
                                                      false)
                                               (l;fail (format "Each line of a multi-line text must have an appropriate offset!\n"
                                                               "Expected: " (%i (nat-to-int offset-column)) "\n"
                                                               "  Actual: " (%i (nat-to-int offset-size)) "\n")))))
                                 ($_ l;either
                                     (do @
                                       [normal (l;many' (l;none-of "\\\"\n"))]
                                       (recur (format text-read normal)
                                              (|> where
                                                  (update@ #;column (n.+ (text;size normal))))
                                              false))
                                     (do @
                                       [[chunk char] escaped-char^]
                                       (recur (format text-read (char;as-text char))
                                              (|> where
                                                  (update@ #;column (n.+ (text;size chunk))))
                                              false))
                                     next-line
                                     (do @
                                       [_ (l;text "\"")]
                                       (wrap [text-read
                                              (|> where
                                                  (update@ #;column n.inc))])))))))]
    (wrap [[where (#;TextS text-read)]
           where'])))

(do-template [<name> <tag> <open> <close>]
  [(def: (<name> where ast^)
     (-> Cursor
         (-> Cursor (Lexer [AST Cursor]))
         (Lexer [AST Cursor]))
     (do Monad<Lexer>
       [_ (l;text <open>)
        [elems where'] (loop [elems (: (V;Vector AST)
                                       V;empty)
                              where where]
                         (l;either (do @
                                     [[elem where'] (ast^ where)]
                                     (recur (V;add elem elems)
                                            where'))
                                   (do @
                                     [[_ where'] (l;either (space^ where)
                                                           (comment^ where))
                                      _ (l;text <close>)]
                                     (wrap [(V;to-list elems)
                                            (|> where'
                                                (update@ #;column n.inc))]))))]
       (wrap [[where (<tag> elems)]
              where'])))]

  [form^   #;FormS   "(" ")"]
  [tuple^  #;TupleS  "[" "]"]
  )

(def: (record^ where ast^)
  (-> Cursor
      (-> Cursor (Lexer [AST Cursor]))
      (Lexer [AST Cursor]))
  (do Monad<Lexer>
    [_ (l;text "{")
     [elems where'] (loop [elems (: (V;Vector [AST AST])
                                    V;empty)
                           where where]
                      (l;either (do @
                                  [[key where] (ast^ where)
                                   [val where'] (ast^ where)]
                                  (recur (V;add [key val] elems)
                                         where'))
                                (do @
                                  [[_ where'] (l;either (space^ where)
                                                        (comment^ where))
                                   _ (l;text "}")]
                                  (wrap [(V;to-list elems)
                                         (|> where'
                                             (update@ #;column n.inc))]))))]
    (wrap [[where (#;RecordS elems)]
           where'])))

(def: ident-part^
  (Lexer Text)
  (do Monad<Lexer>
    [#let [digits "0123456789"
           delimiters "()[]{}#;"
           space "\t\v \n\r\f"
           head-lexer (l;none-of (format digits delimiters space))
           tail-lexer (l;some' (l;none-of (format delimiters space)))]
     head head-lexer
     tail tail-lexer]
    (wrap (format (char;as-text head)
                  tail))))

(def: ident^
  (Lexer [Ident Nat])
  ($_ l;either
      (do Monad<Lexer>
        [_ (l;text ";;")
         def-name ident-part^]
        (l;fail "Cannot handle ;; syntax for identifiers."))
      (do Monad<Lexer>
        [_ (l;text ";")
         def-name ident-part^]
        (wrap [["lux" def-name]
               (n.inc (text;size def-name))]))
      (do Monad<Lexer>
        [first-part ident-part^]
        (l;either (do @
                    [_ (l;char #";")
                     second-part ident-part^]
                    (wrap [[first-part second-part]
                           ($_ n.+
                               (text;size first-part)
                               +1
                               (text;size second-part))]))
                  (wrap [["" first-part]
                         (text;size first-part)])))))

(do-template [<name> <tag> <lexer> <extra>]
  [(def: (<name> where)
     (-> Cursor (Lexer [AST Cursor]))
     (do Monad<Lexer>
       [[value length] <lexer>]
       (wrap [[where (<tag> value)]
              (|> where
                  (update@ #;column (function [column] ($_ n.+ column <extra> length))))])))]

  [symbol^ #;SymbolS ident^                         +0]
  [tag^    #;TagS    (l;after (l;char #"#") ident^) +1]
  )

(def: #export (ast^ where)
  (-> Cursor (Lexer [AST Cursor]))
  (do Monad<Lexer>
    [[_ where] (l;either (space^ where)
                         (comment^ where))]
    ($_ l;either
        (bool^ where)
        (nat^ where)
        (real^ where)
        (int^ where)
        (deg^ where)
        (char^ where)
        (text^ where)
        (symbol^ where)
        (tag^ where)
        (form^ where ast^)
        (tuple^ where ast^)
        (record^ where ast^)
        )))