(.module: {#.doc "Codecs for values in the JSON format."}
  [library
   [lux #*
    ["." debug]
    [abstract
     [monad (#+ Monad do)]
     [equivalence (#+ Equivalence)]
     ["." codec]]
    [control
     ["." try]
     ["<>" parser
      ["<.>" type]
      ["</>" json]]]
    [data
     ["." bit]
     maybe
     ["." sum]
     ["." product]
     ["." text ("#\." equivalence)
      ["%" format (#+ format)]]
     [collection
      ["." list ("#\." fold monad)]
      ["." row (#+ Row row) ("#\." monad)]
      ["d" dictionary]]]
    [macro
     [syntax (#+ syntax:)]
     ["." code]
     ["." poly (#+ poly:)]]
    [math
     [number
      ["." i64]
      ["n" nat ("#\." decimal)]
      ["." int]
      ["." frac ("#\." decimal)]]]
    [time
     ## ["." instant]
     ## ["." duration]
     ["." date]
     ["." day]
     ["." month]]
    ["." type
     ["." unit]]]]
  [\\library
   ["." / (#+ JSON)]])

(def: tag
  (-> Nat Frac)
  (|>> .int int.frac))

(def: (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 (i64.left_shift 32) dec))
(def: high_mask Nat (|> low_mask (i64.left_shift 32)))

(implementation: nat_codec
  (codec.Codec JSON Nat)
  
  (def: (encode input)
    (let [high (|> input (i64.and high_mask) (i64.right_shift 32))
          low (i64.and low_mask input)]
      (#/.Array (row (|> high .int int.frac #/.Number)
                     (|> low .int int.frac #/.Number)))))
  (def: decode
    (</>.run (</>.array
              (do <>.monad
                [high </>.number
                 low </>.number]
                (wrap (n.+ (|> high frac.int .nat (i64.left_shift 32))
                           (|> low frac.int .nat))))))))

(implementation: int_codec
  (codec.Codec JSON Int)
  
  (def: encode (|>> .nat (\ nat_codec encode)))
  (def: decode
    (|>> (\ nat_codec decode) (\ try.functor map .int))))

(def: (nullable writer)
  {#.doc "Builds a JSON generator for potentially inexistent values."}
  (All [a] (-> (-> a JSON) (-> (Maybe a) JSON)))
  (function (_ elem)
    (case elem
      #.None         #/.Null
      (#.Some value) (writer value))))

(implementation: qty_codec
  (All [unit]
    (codec.Codec JSON (unit.Qty unit)))
  
  (def: encode
    (|>> ((debug.private unit.out))
         (\ ..int_codec encode)))
  (def: decode
    (|>> (\ ..int_codec decode)
         (\ try.functor map (debug.private unit.in)))))

(poly: encode
  (with_expansions
    [<basic> (template [<matcher> <encoder>]
               [(do !
                  [#let [g!_ (code.local_identifier "_______")]
                   _ <matcher>]
                  (wrap (` (: (~ (@JSON\encode inputT))
                              <encoder>))))]

               [(<type>.exactly Any) (function ((~ g!_) (~ (code.identifier ["" "0"]))) #/.Null)]
               [(<type>.sub Bit)     (|>> #/.Boolean)]
               [(<type>.sub Nat)     (\ (~! ..nat_codec) (~' encode))]
               [(<type>.sub Int)     (\ (~! ..int_codec) (~' encode))]
               [(<type>.sub Frac)    (|>> #/.Number)]
               [(<type>.sub Text)    (|>> #/.String)])
     <time> (template [<type> <codec>]
              [(do !
                 [_ (<type>.exactly <type>)]
                 (wrap (` (: (~ (@JSON\encode inputT))
                             (|>> (\ (~! <codec>) (~' encode)) #/.String)))))]

              ## [duration.Duration duration.codec]
              ## [instant.Instant instant.codec]
              [date.Date date.codec]
              [day.Day day.codec]
              [month.Month month.codec])]
    (do {! <>.monad}
      [*env* <type>.env
       #let [@JSON\encode (: (-> Type Code)
                             (function (_ type)
                               (` (-> (~ (poly.to_code *env* type)) /.JSON))))]
       inputT <type>.peek]
      ($_ <>.either
          <basic>
          <time>
          (do !
            [unitT (<type>.apply (<>.after (<type>.exactly unit.Qty)
                                           <type>.any))]
            (wrap (` (: (~ (@JSON\encode inputT))
                        (\ (~! qty_codec) (~' encode))))))
          (do !
            [#let [g!_ (code.local_identifier "_______")
                   g!key (code.local_identifier "_______key")
                   g!val (code.local_identifier "_______val")]
             [_ _ =val=] (<type>.apply ($_ <>.and
                                           (<type>.exactly d.Dictionary)
                                           (<type>.exactly .Text)
                                           encode))]
            (wrap (` (: (~ (@JSON\encode inputT))
                        (|>> ((~! d.entries))
                             ((~! list\map) (function ((~ g!_) [(~ g!key) (~ g!val)])
                                              [(~ g!key) ((~ =val=) (~ g!val))]))
                             ((~! d.from_list) (~! text.hash))
                             #/.Object)))))
          (do !
            [[_ =sub=] (<type>.apply ($_ <>.and
                                         (<type>.exactly .Maybe)
                                         encode))]
            (wrap (` (: (~ (@JSON\encode inputT))
                        ((~! ..nullable) (~ =sub=))))))
          (do !
            [[_ =sub=] (<type>.apply ($_ <>.and
                                         (<type>.exactly .List)
                                         encode))]
            (wrap (` (: (~ (@JSON\encode inputT))
                        (|>> ((~! list\map) (~ =sub=)) ((~! row.from_list)) #/.Array)))))
          (do !
            [#let [g!_ (code.local_identifier "_______")
                   g!input (code.local_identifier "_______input")]
             members (<type>.variant (<>.many encode))
             #let [last (dec (list.size members))]]
            (wrap (` (: (~ (@JSON\encode inputT))
                        (function ((~ g!_) (~ g!input))
                          (case (~ g!input)
                            (~+ (list\join (list\map (function (_ [tag g!encode])
                                                       (if (n.= last tag)
                                                         (list (` ((~ (code.nat (dec tag))) #1 (~ g!input)))
                                                               (` ((~! /.json) [(~ (code.frac (..tag (dec tag))))
                                                                                #1
                                                                                ((~ g!encode) (~ g!input))])))
                                                         (list (` ((~ (code.nat tag)) #0 (~ g!input)))
                                                               (` ((~! /.json) [(~ (code.frac (..tag tag)))
                                                                                #0
                                                                                ((~ g!encode) (~ g!input))])))))
                                                     (list.enumeration members))))))))))
          (do !
            [g!encoders (<type>.tuple (<>.many encode))
             #let [g!_ (code.local_identifier "_______")
                   g!members (|> (list.size g!encoders)
                                 list.indices
                                 (list\map (|>> n\encode code.local_identifier)))]]
            (wrap (` (: (~ (@JSON\encode inputT))
                        (function ((~ g!_) [(~+ g!members)])
                          ((~! /.json) [(~+ (list\map (function (_ [g!member g!encode])
                                                        (` ((~ g!encode) (~ g!member))))
                                                      (list.zip/2 g!members g!encoders)))]))))))
          ## Type recursion
          (do !
            [[selfC non_recC] (<type>.recursive encode)
             #let [g! (code.local_identifier "____________")]]
            (wrap (` (: (~ (@JSON\encode inputT))
                        ((~! ..rec_encode) (.function ((~ g!) (~ selfC))
                                             (~ non_recC)))))))
          <type>.recursive_self
          ## Type applications
          (do !
            [partsC (<type>.apply (<>.many encode))]
            (wrap (` ((~+ partsC)))))
          ## Polymorphism
          (do !
            [[funcC varsC bodyC] (<type>.polymorphic encode)]
            (wrap (` (: (All [(~+ varsC)]
                          (-> (~+ (list\map (function (_ varC) (` (-> (~ varC) /.JSON)))
                                            varsC))
                              (-> ((~ (poly.to_code *env* inputT)) (~+ varsC))
                                  /.JSON)))
                        (function ((~ funcC) (~+ varsC))
                          (~ bodyC))))))
          <type>.parameter
          <type>.recursive_call
          ## If all else fails...
          (<>.fail (format "Cannot create JSON encoder for: " (type.format inputT)))
          ))))

(poly: decode
  (with_expansions
    [<basic> (template [<matcher> <decoder>]
               [(do !
                  [_ <matcher>]
                  (wrap (` (: (~ (@JSON\decode inputT))
                              (~! <decoder>)))))]

               [(<type>.exactly Any)  </>.null]
               [(<type>.sub Bit)      </>.boolean]
               [(<type>.sub Nat)      (<>.codec ..nat_codec </>.any)]
               [(<type>.sub Int)      (<>.codec ..int_codec </>.any)]
               [(<type>.sub Frac)     </>.number]
               [(<type>.sub Text)     </>.string])
     <time> (template [<type> <codec>]
              [(do !
                 [_ (<type>.exactly <type>)]
                 (wrap (` (: (~ (@JSON\decode inputT))
                             ((~! <>.codec) (~! <codec>) (~! </>.string))))))]

              ## [duration.Duration duration.codec]
              ## [instant.Instant instant.codec]
              [date.Date date.codec]
              [day.Day day.codec]
              [month.Month month.codec])]
    (do {! <>.monad}
      [*env* <type>.env
       #let [@JSON\decode (: (-> Type Code)
                             (function (_ type)
                               (` (</>.Parser (~ (poly.to_code *env* type))))))]
       inputT <type>.peek]
      ($_ <>.either
          <basic>
          <time>
          (do !
            [unitT (<type>.apply (<>.after (<type>.exactly unit.Qty)
                                           <type>.any))]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! <>.codec) (~! qty_codec) (~! </>.any))))))
          (do !
            [[_ _ valC] (<type>.apply ($_ <>.and
                                          (<type>.exactly d.Dictionary)
                                          (<type>.exactly .Text)
                                          decode))]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! </>.dictionary) (~ valC))))))
          (do !
            [[_ subC] (<type>.apply (<>.and (<type>.exactly .Maybe)
                                            decode))]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! </>.nullable) (~ subC))))))
          (do !
            [[_ subC] (<type>.apply (<>.and (<type>.exactly .List)
                                            decode))]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! </>.array) ((~! <>.some) (~ subC)))))))
          (do !
            [members (<type>.variant (<>.many decode))
             #let [last (dec (list.size members))]]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ($_ ((~! <>.or))
                            (~+ (list\map (function (_ [tag memberC])
                                            (if (n.= last tag)
                                              (` (|> (~ memberC)
                                                     ((~! <>.after) ((~! </>.boolean!) (~ (code.bit #1))))
                                                     ((~! <>.after) ((~! </>.number!) (~ (code.frac (..tag (dec tag))))))
                                                     ((~! </>.array))))
                                              (` (|> (~ memberC)
                                                     ((~! <>.after) ((~! </>.boolean!) (~ (code.bit #0))))
                                                     ((~! <>.after) ((~! </>.number!) (~ (code.frac (..tag tag)))))
                                                     ((~! </>.array))))))
                                          (list.enumeration members))))))))
          (do !
            [g!decoders (<type>.tuple (<>.many decode))]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! </>.array) ($_ ((~! <>.and)) (~+ g!decoders)))))))
          ## Type recursion
          (do !
            [[selfC bodyC] (<type>.recursive decode)
             #let [g! (code.local_identifier "____________")]]
            (wrap (` (: (~ (@JSON\decode inputT))
                        ((~! <>.rec) (.function ((~ g!) (~ selfC))
                                       (~ bodyC)))))))
          <type>.recursive_self
          ## Type applications
          (do !
            [[funcC argsC] (<type>.apply (<>.and decode (<>.many decode)))]
            (wrap (` ((~ funcC) (~+ argsC)))))
          ## Polymorphism
          (do !
            [[funcC varsC bodyC] (<type>.polymorphic decode)]
            (wrap (` (: (All [(~+ varsC)]
                          (-> (~+ (list\map (|>> (~) </>.Parser (`)) varsC))
                              (</>.Parser ((~ (poly.to_code *env* inputT)) (~+ varsC)))))
                        (function ((~ funcC) (~+ varsC))
                          (~ bodyC))))))
          <type>.parameter
          <type>.recursive_call
          ## If all else fails...
          (<>.fail (format "Cannot create JSON decoder for: " (type.format inputT)))
          ))))

(syntax: #export (codec inputT)
  {#.doc (doc "A macro for automatically producing JSON codecs."
              (type: Variant
                (#Bit Bit)
                (#Text Text)
                (#Frac Frac))

              (type: Record
                {#bit Bit
                 #frac Frac
                 #text Text
                 #maybe (Maybe Frac)
                 #list (List Frac)
                 #variant Variant
                 #tuple [Bit Frac Text]
                 #dictionary (Dictionary Text Frac)})

              (derived: (..codec Record)))}
  (wrap (list (` (: (codec.Codec /.JSON (~ inputT))
                    (implementation
                     (def: (~' encode)
                       ((~! ..encode) (~ inputT)))
                     (def: (~' decode)
                       ((~! </>.run) ((~! ..decode) (~ inputT))))
                     ))))))