(;module: {#;doc "Codecs for values in the JSON format.

                  For more information, please see: http://www.json.org/"}
  lux
  (lux (control functor
                applicative
                [monad #+ do Monad]
                [eq #+ Eq]
                codec
                ["p" parser "p/" Monad<Parser>])
       (data [bool]
             [bit]
             [text "text/" Eq<Text> Monoid<Text>]
             (text ["l" lexer])
             [number "real/" Codec<Text,Real> "nat/" Codec<Text,Nat>]
             maybe
             ["R" result]
             [sum]
             [product]
             (coll [list "L/" Fold<List> Monad<List>]
                   [vector #+ Vector vector "Vector/" Monad<Vector>]
                   ["d" dict]))
       (time ["i" instant]
             ["du" duration]
             ["da" date])
       [macro #+ Monad<Lux> with-gensyms]
       (macro ["s" syntax #+ syntax:]
              [code]
              [poly #+ poly:])
       [type]
       )
  [.. #+ JSON]
  [../reader])

## [Values]
(def: #hidden (show-null _) (-> ..;Null Text) "null")
(do-template [<name> <type> <codec>]
  [(def: <name> (-> <type> Text) <codec>)]

  [show-boolean ..;Boolean (:: bool;Codec<Text,Bool> encode)]
  [show-number  ..;Number (:: number;Codec<Text,Real> encode)]
  [show-string  ..;String text;encode])

(def: (show-array show-json elems)
  (-> (-> JSON Text) (-> ..;Array Text))
  ($_ text/append "["
      (|> elems (Vector/map show-json) vector;to-list (text;join-with ","))
      "]"))

(def: (show-object show-json object)
  (-> (-> JSON Text) (-> ..;Object Text))
  ($_ text/append "{"
      (|> object
          d;entries
          (L/map (function [[key value]] ($_ text/append (show-string key) ":" (show-json value))))
          (text;join-with ","))
      "}"))

(def: (show-json json)
  (-> JSON Text)
  (case json
    (^template [<tag> <show>]
      (<tag> value)
      (<show> value))
    ([#..;Null    show-null]
     [#..;Boolean show-boolean]
     [#..;Number  show-number]
     [#..;String  show-string]
     [#..;Array   (show-array show-json)]
     [#..;Object  (show-object show-json)])
    ))

(def: space~
  (l;Lexer Text)
  (l;some l;space))

(def: data-sep
  (l;Lexer [Text Unit Text])
  ($_ p;seq space~ (l;this ",") space~))

(def: null~
  (l;Lexer ..;Null)
  (do p;Monad<Parser>
    [_ (l;this "null")]
    (wrap [])))

(do-template [<name> <token> <value>]
  [(def: <name>
     (l;Lexer ..;Boolean)
     (do p;Monad<Parser>
       [_ (l;this <token>)]
       (wrap <value>)))]

  [t~ "true"  true]
  [f~ "false" false]
  )

(def: boolean~
  (l;Lexer ..;Boolean)
  (p;either t~ f~))

(def: number~
  (l;Lexer ..;Number)
  (do p;Monad<Parser>
    [signed? (l;this? "-")
     digits (l;many l;decimal)
     decimals (p;default "0"
                (do @
                  [_ (l;this ".")]
                  (l;many l;decimal)))
     exp (p;default ""
           (do @
             [mark (l;one-of "eE")
              signed?' (l;this? "-")
              offset (l;many l;decimal)]
             (wrap ($_ text/append mark (if signed?' "-" "") offset))))]
    (case (real/decode ($_ text/append (if signed? "-" "") digits "." decimals exp))
      (#R;Error message)
      (p;fail message)
      
      (#R;Success value)
      (wrap value))))

(def: escaped~
  (l;Lexer Text)
  ($_ p;either
      (p;after (l;this "\\t") (p/wrap "\t"))
      (p;after (l;this "\\b") (p/wrap "\b"))
      (p;after (l;this "\\n") (p/wrap "\n"))
      (p;after (l;this "\\r") (p/wrap "\r"))
      (p;after (l;this "\\f") (p/wrap "\f"))
      (p;after (l;this "\\\"") (p/wrap "\""))
      (p;after (l;this "\\\\") (p/wrap "\\"))))

(def: string~
  (l;Lexer ..;String)
  (<| (l;enclosed ["\"" "\""])
      (loop [_ []])
      (do p;Monad<Parser>
        [chars (l;some (l;none-of "\\\""))
         stop l;peek])
      (if (text/= "\\" stop)
        (do @
          [escaped escaped~
           next-chars (recur [])]
          (wrap ($_ text/append chars escaped next-chars)))
        (wrap chars))))

(def: (kv~ json~)
  (-> (-> Unit (l;Lexer JSON)) (l;Lexer [..;String JSON]))
  (do p;Monad<Parser>
    [key string~
     _ space~
     _ (l;this ":")
     _ space~
     value (json~ [])]
    (wrap [key value])))

(do-template [<name> <type> <open> <close> <elem-parser> <prep>]
  [(def: (<name> json~)
     (-> (-> Unit (l;Lexer JSON)) (l;Lexer <type>))
     (do p;Monad<Parser>
       [_ (l;this <open>)
        _ space~
        elems (p;sep-by data-sep <elem-parser>)
        _ space~
        _ (l;this <close>)]
       (wrap (<prep> elems))))]

  [array~  ..;Array  "[" "]" (json~ [])  vector;from-list]
  [object~ ..;Object "{" "}" (kv~ json~) (d;from-list text;Hash<Text>)]
  )

(def: (json~' _)
  (-> Unit (l;Lexer JSON))
  ($_ p;alt null~ boolean~ number~ string~ (array~ json~') (object~ json~')))

(struct: #export _ (Codec Text JSON)
  (def: encode show-json)
  (def: decode (function [input] (l;run input (json~' [])))))

## [Polytypism]
(def: #hidden _map_
  (All [a b] (-> (-> a b) (List a) (List b)))
  L/map)

(def: tag
  (-> Nat Real)
  (|>. nat-to-int int-to-real))

(def: #hidden (rec-encode non-rec)
  (All [a] (-> (-> (-> a JSON)
                   (-> a JSON))
               (-> a JSON)))
  (function [input]
    (non-rec (rec-encode non-rec) input)))

(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
(def: high-mask Nat (|> low-mask (bit;shift-left +32)))

(struct: #hidden _ (Codec JSON Nat)
  (def: (encode input)
    (let [high (|> input (bit;and high-mask) (bit;unsigned-shift-right +32))
          low (bit;and low-mask input)]
      (..;array (vector (|> high nat-to-int int-to-real #..;Number)
                        (|> low nat-to-int int-to-real #..;Number)))))
  (def: (decode input)
    (<| (../reader;run input)
        (do p;Monad<Parser>
          [high ../reader;number
           low ../reader;number])
        (wrap (n.+ (|> high real-to-int int-to-nat (bit;shift-left +32))
                   (|> low real-to-int int-to-nat))))))

(struct: #hidden _ (Codec JSON Int)
  (def: encode (|>. int-to-nat (:: Codec<JSON,Nat> encode)))
  (def: decode
    (|>. (:: Codec<JSON,Nat> decode) (:: R;Functor<Result> map nat-to-int))))

(poly: #hidden Codec<JSON,?>//encode
  (with-expansions
    [<basic> (do-template [<type> <matcher> <encoder>]
               [(do @
                  [_ <matcher>]
                  (wrap (` (: (~ (@JSON//encode inputT))
                              <encoder>))))]

               [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
               [Bool poly;bool ..;boolean]
               [Nat  poly;nat  (:: ;;Codec<JSON,Nat> (~' encode))]
               [Int  poly;int  (:: ;;Codec<JSON,Int> (~' encode))]
               [Real poly;real ..;number]
               [Text poly;text ..;string])
     <time> (do-template [<type> <codec>]
              [(do @
                 [_ (poly;named (ident-for <type>))]
                 (wrap (` (: (~ (@JSON//encode inputT))
                             (|>. (:: <codec> (~' encode)) ..;string)))))]

              [du;Duration du;Codec<Text,Duration>]
              [i;Instant   i;Codec<Text,Instant>]
              [da;Date     da;Codec<Text,Date>]
              [da;Day      da;Codec<Text,Day>]
              [da;Month    da;Codec<Text,Month>])]
    (do @
      [*env* poly;env
       #let [@JSON//encode (: (-> Type Code)
                              (function [type]
                                (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
       inputT poly;peek]
      ($_ p;either
          <basic>
          <time>
          (do @
            [#let [g!key (code;local-symbol "\u0000key")
                   g!val (code;local-symbol "\u0000val")]
             [_ _ .val.] (poly;apply ($_ p;seq
                                         (poly;named (ident-for d;Dict))
                                         poly;text
                                         Codec<JSON,?>//encode))]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (|>. d;entries
                             (;;_map_ (function [[(~ g!key) (~ g!val)]]
                                        [(~ g!key) ((~ .val.) (~ g!val))]))
                             (d;from-list text;Hash<Text>)
                             #..;Object)))))
          (do @
            [[_ .sub.] (poly;apply ($_ p;seq
                                       (poly;named (ident-for ;Maybe))
                                       Codec<JSON,?>//encode))]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (..;nullable (~ .sub.))))))
          (do @
            [[_ .sub.] (poly;apply ($_ p;seq
                                       (poly;named (ident-for ;List))
                                       Codec<JSON,?>//encode))]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
          (do @
            [#let [g!input (code;local-symbol "\u0000input")]
             members (poly;variant (p;many Codec<JSON,?>//encode))]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (function [(~ g!input)]
                          (case (~ g!input)
                            (~@ (L/join (L/map (function [[tag g!encode]]
                                                 (list (` ((~ (code;nat tag)) (~ g!input)))
                                                       (` (..;json [(~ (code;real (;;tag tag)))
                                                                    ((~ g!encode) (~ g!input))]))))
                                               (list;enumerate members))))))))))
          (do @
            [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
             #let [g!members (|> (list;size g!encoders) n.dec
                                 (list;n.range +0)
                                 (L/map (|>. nat/encode code;local-symbol)))]]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (function [[(~@ g!members)]]
                          (..;json [(~@ (L/map (function [[g!member g!encode]]
                                                 (` ((~ g!encode) (~ g!member))))
                                               (list;zip2 g!members g!encoders)))]))))))
          ## Type recursion
          (do @
            [[selfC non-recC] (poly;recursive Codec<JSON,?>//encode)]
            (wrap (` (: (~ (@JSON//encode inputT))
                        (;;rec-encode (;function [(~ selfC)]
                                        (~ non-recC)))))))
          poly;recursive-self
          ## Type applications
          (do @
            [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
            (wrap (` ((~@ partsC)))))
          ## Polymorphism
          (do @
            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
            (wrap (` (: (All [(~@ varsC)]
                          (-> (~@ (L/map (function [varC] (` (->  (~ varC) ..;JSON)))
                                         varsC))
                              (-> ((~ (poly;to-ast *env* inputT)) (~@ varsC))
                                  ..;JSON)))
                        (function (~ funcC) [(~@ varsC)]
                          (~ bodyC))))))
          poly;bound
          poly;recursive-call
          ## If all else fails...
          (p;fail (text/append "Cannot create JSON encoder for: " (type;to-text inputT)))
          ))))

(poly: #hidden Codec<JSON,?>//decode
  (with-expansions
    [<basic> (do-template [<type> <matcher> <decoder>]
               [(do @
                  [_ <matcher>]
                  (wrap (` (: (~ (@JSON//decode inputT))
                              <decoder>))))]

               [Unit poly;unit ../reader;null]
               [Bool poly;bool ../reader;boolean]
               [Nat  poly;nat  (p;codec ;;Codec<JSON,Nat> ../reader;any)]
               [Int  poly;int  (p;codec ;;Codec<JSON,Int> ../reader;any)]
               [Real poly;real ../reader;number]
               [Text poly;text ../reader;string])
     <time> (do-template [<type> <codec>]
              [(do @
                 [_ (poly;named (ident-for <type>))]
                 (wrap (` (: (~ (@JSON//decode inputT))
                             (p;codec <codec> ../reader;string)))))]

              [du;Duration du;Codec<Text,Duration>]
              [i;Instant   i;Codec<Text,Instant>]
              [da;Date     da;Codec<Text,Date>]
              [da;Day      da;Codec<Text,Day>]
              [da;Month    da;Codec<Text,Month>])]
    (do @
      [*env* poly;env
       #let [@JSON//decode (: (-> Type Code)
                              (function [type]
                                (` (..;Reader (~ (poly;to-ast *env* type))))))]
       inputT poly;peek]
      ($_ p;either
          <basic>
          <time>
          (do @
            [[_ _ valC] (poly;apply ($_ p;seq
                                        (poly;named (ident-for d;Dict))
                                        poly;text
                                        Codec<JSON,?>//decode))]
            (wrap (` (: (~ (@JSON//decode inputT))
                        (../reader;object (~ valC))))))
          (do @
            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;Maybe))
                                         Codec<JSON,?>//decode))]
            (wrap (` (: (~ (@JSON//decode inputT))
                        (../reader;nullable (~ subC))))))
          (do @
            [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;List))
                                         Codec<JSON,?>//decode))]
            (wrap (` (: (~ (@JSON//decode inputT))
                        (../reader;array (p;some (~ subC)))))))
          (do @
            [members (poly;variant (p;many Codec<JSON,?>//decode))]
            (wrap (` (: (~ (@JSON//decode inputT))
                        ($_ p;alt
                            (~@ (L/map (function [[tag memberC]]
                                         (` (|> (~ memberC)
                                                (p;after (../reader;number! (~ (code;real (;;tag tag)))))
                                                ../reader;array)))
                                       (list;enumerate members))))))))
          (do @
            [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
            (wrap (` (: (~ (@JSON//decode inputT))
                        (../reader;array ($_ p;seq (~@ g!decoders)))))))
          ## Type recursion
          (do @
            [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
            (wrap (` (: (~ (@JSON//decode inputT))
                        (p;rec (;function [(~ selfC)]
                                 (~ bodyC)))))))
          poly;recursive-self
          ## Type applications
          (do @
            [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
            (wrap (` ((~ funcC) (~@ argsC)))))
          ## Polymorphism
          (do @
            [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
            (wrap (` (: (All [(~@ varsC)]
                          (-> (~@ (L/map (|>. (~) ..;Reader (`)) varsC))
                              (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
                        (function (~ funcC) [(~@ varsC)]
                          (~ bodyC))))))
          poly;bound
          poly;recursive-call
          ## If all else fails...
          (p;fail (text/append "Cannot create JSON decoder for: " (type;to-text inputT)))
          ))))

(syntax: #export (Codec<JSON,?> inputT)
  {#;doc (doc "A macro for automatically producing JSON codecs."
              (type: Variant
                (#Case0 Bool)
                (#Case1 Text)
                (#Case2 Real))

              (type: Record
                {#unit Unit
                 #bool Bool
                 #real Real
                 #text Text
                 #maybe (Maybe Real)
                 #list (List Real)
                 #variant Variant
                 #tuple [Bool Real Text]
                 #dict (Dict Text Real)})

              (derived: (Codec<JSON,?> Record)))}
  (with-gensyms [g!inputs]
    (wrap (list (` (: (Codec ..;JSON (~ inputT))
                      (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
                              (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
                              )))))))